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         return newSVOP(OP_CONST, 0, sv);
2330     }
2331
2332   nope:
2333     if (!(PL_opargs[type] & OA_OTHERINT))
2334         return o;
2335
2336     if (!(PL_hints & HINT_INTEGER)) {
2337         if (type == OP_MODULO
2338             || type == OP_DIVIDE
2339             || !(o->op_flags & OPf_KIDS))
2340         {
2341             return o;
2342         }
2343
2344         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2345             if (curop->op_type == OP_CONST) {
2346                 if (SvIOK(((SVOP*)curop)->op_sv))
2347                     continue;
2348                 return o;
2349             }
2350             if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2351                 continue;
2352             return o;
2353         }
2354         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2355     }
2356
2357     return o;
2358 }
2359
2360 OP *
2361 Perl_gen_constant_list(pTHX_ register OP *o)
2362 {
2363     register OP *curop;
2364     I32 oldtmps_floor = PL_tmps_floor;
2365
2366     list(o);
2367     if (PL_error_count)
2368         return o;               /* Don't attempt to run with errors */
2369
2370     PL_op = curop = LINKLIST(o);
2371     o->op_next = 0;
2372     peep(curop);
2373     pp_pushmark();
2374     CALLRUNOPS(aTHX);
2375     PL_op = curop;
2376     pp_anonlist();
2377     PL_tmps_floor = oldtmps_floor;
2378
2379     o->op_type = OP_RV2AV;
2380     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2381     curop = ((UNOP*)o)->op_first;
2382     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2383     op_free(curop);
2384     linklist(o);
2385     return list(o);
2386 }
2387
2388 OP *
2389 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2390 {
2391     if (!o || o->op_type != OP_LIST)
2392         o = newLISTOP(OP_LIST, 0, o, Nullop);
2393     else
2394         o->op_flags &= ~OPf_WANT;
2395
2396     if (!(PL_opargs[type] & OA_MARK))
2397         op_null(cLISTOPo->op_first);
2398
2399     o->op_type = type;
2400     o->op_ppaddr = PL_ppaddr[type];
2401     o->op_flags |= flags;
2402
2403     o = CHECKOP(type, o);
2404     if (o->op_type != type)
2405         return o;
2406
2407     return fold_constants(o);
2408 }
2409
2410 /* List constructors */
2411
2412 OP *
2413 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2414 {
2415     if (!first)
2416         return last;
2417
2418     if (!last)
2419         return first;
2420
2421     if (first->op_type != type
2422         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2423     {
2424         return newLISTOP(type, 0, first, last);
2425     }
2426
2427     if (first->op_flags & OPf_KIDS)
2428         ((LISTOP*)first)->op_last->op_sibling = last;
2429     else {
2430         first->op_flags |= OPf_KIDS;
2431         ((LISTOP*)first)->op_first = last;
2432     }
2433     ((LISTOP*)first)->op_last = last;
2434     return first;
2435 }
2436
2437 OP *
2438 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2439 {
2440     if (!first)
2441         return (OP*)last;
2442
2443     if (!last)
2444         return (OP*)first;
2445
2446     if (first->op_type != type)
2447         return prepend_elem(type, (OP*)first, (OP*)last);
2448
2449     if (last->op_type != type)
2450         return append_elem(type, (OP*)first, (OP*)last);
2451
2452     first->op_last->op_sibling = last->op_first;
2453     first->op_last = last->op_last;
2454     first->op_flags |= (last->op_flags & OPf_KIDS);
2455
2456 #ifdef PL_OP_SLAB_ALLOC
2457 #else
2458     Safefree(last);
2459 #endif
2460     return (OP*)first;
2461 }
2462
2463 OP *
2464 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2465 {
2466     if (!first)
2467         return last;
2468
2469     if (!last)
2470         return first;
2471
2472     if (last->op_type == type) {
2473         if (type == OP_LIST) {  /* already a PUSHMARK there */
2474             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2475             ((LISTOP*)last)->op_first->op_sibling = first;
2476             if (!(first->op_flags & OPf_PARENS))
2477                 last->op_flags &= ~OPf_PARENS;
2478         }
2479         else {
2480             if (!(last->op_flags & OPf_KIDS)) {
2481                 ((LISTOP*)last)->op_last = first;
2482                 last->op_flags |= OPf_KIDS;
2483             }
2484             first->op_sibling = ((LISTOP*)last)->op_first;
2485             ((LISTOP*)last)->op_first = first;
2486         }
2487         last->op_flags |= OPf_KIDS;
2488         return last;
2489     }
2490
2491     return newLISTOP(type, 0, first, last);
2492 }
2493
2494 /* Constructors */
2495
2496 OP *
2497 Perl_newNULLLIST(pTHX)
2498 {
2499     return newOP(OP_STUB, 0);
2500 }
2501
2502 OP *
2503 Perl_force_list(pTHX_ OP *o)
2504 {
2505     if (!o || o->op_type != OP_LIST)
2506         o = newLISTOP(OP_LIST, 0, o, Nullop);
2507     op_null(o);
2508     return o;
2509 }
2510
2511 OP *
2512 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2513 {
2514     LISTOP *listop;
2515
2516     NewOp(1101, listop, 1, LISTOP);
2517
2518     listop->op_type = type;
2519     listop->op_ppaddr = PL_ppaddr[type];
2520     if (first || last)
2521         flags |= OPf_KIDS;
2522     listop->op_flags = flags;
2523
2524     if (!last && first)
2525         last = first;
2526     else if (!first && last)
2527         first = last;
2528     else if (first)
2529         first->op_sibling = last;
2530     listop->op_first = first;
2531     listop->op_last = last;
2532     if (type == OP_LIST) {
2533         OP* pushop;
2534         pushop = newOP(OP_PUSHMARK, 0);
2535         pushop->op_sibling = first;
2536         listop->op_first = pushop;
2537         listop->op_flags |= OPf_KIDS;
2538         if (!last)
2539             listop->op_last = pushop;
2540     }
2541
2542     return (OP*)listop;
2543 }
2544
2545 OP *
2546 Perl_newOP(pTHX_ I32 type, I32 flags)
2547 {
2548     OP *o;
2549     NewOp(1101, o, 1, OP);
2550     o->op_type = type;
2551     o->op_ppaddr = PL_ppaddr[type];
2552     o->op_flags = flags;
2553
2554     o->op_next = o;
2555     o->op_private = 0 + (flags >> 8);
2556     if (PL_opargs[type] & OA_RETSCALAR)
2557         scalar(o);
2558     if (PL_opargs[type] & OA_TARGET)
2559         o->op_targ = pad_alloc(type, SVs_PADTMP);
2560     return CHECKOP(type, o);
2561 }
2562
2563 OP *
2564 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2565 {
2566     UNOP *unop;
2567
2568     if (!first)
2569         first = newOP(OP_STUB, 0);
2570     if (PL_opargs[type] & OA_MARK)
2571         first = force_list(first);
2572
2573     NewOp(1101, unop, 1, UNOP);
2574     unop->op_type = type;
2575     unop->op_ppaddr = PL_ppaddr[type];
2576     unop->op_first = first;
2577     unop->op_flags = flags | OPf_KIDS;
2578     unop->op_private = 1 | (flags >> 8);
2579     unop = (UNOP*) CHECKOP(type, unop);
2580     if (unop->op_next)
2581         return (OP*)unop;
2582
2583     return fold_constants((OP *) unop);
2584 }
2585
2586 OP *
2587 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2588 {
2589     BINOP *binop;
2590     NewOp(1101, binop, 1, BINOP);
2591
2592     if (!first)
2593         first = newOP(OP_NULL, 0);
2594
2595     binop->op_type = type;
2596     binop->op_ppaddr = PL_ppaddr[type];
2597     binop->op_first = first;
2598     binop->op_flags = flags | OPf_KIDS;
2599     if (!last) {
2600         last = first;
2601         binop->op_private = 1 | (flags >> 8);
2602     }
2603     else {
2604         binop->op_private = 2 | (flags >> 8);
2605         first->op_sibling = last;
2606     }
2607
2608     binop = (BINOP*)CHECKOP(type, binop);
2609     if (binop->op_next || binop->op_type != type)
2610         return (OP*)binop;
2611
2612     binop->op_last = binop->op_first->op_sibling;
2613
2614     return fold_constants((OP *)binop);
2615 }
2616
2617 static int
2618 uvcompare(const void *a, const void *b)
2619 {
2620     if (*((UV *)a) < (*(UV *)b))
2621         return -1;
2622     if (*((UV *)a) > (*(UV *)b))
2623         return 1;
2624     if (*((UV *)a+1) < (*(UV *)b+1))
2625         return -1;
2626     if (*((UV *)a+1) > (*(UV *)b+1))
2627         return 1;
2628     return 0;
2629 }
2630
2631 OP *
2632 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2633 {
2634     SV *tstr = ((SVOP*)expr)->op_sv;
2635     SV *rstr = ((SVOP*)repl)->op_sv;
2636     STRLEN tlen;
2637     STRLEN rlen;
2638     U8 *t = (U8*)SvPV(tstr, tlen);
2639     U8 *r = (U8*)SvPV(rstr, rlen);
2640     register I32 i;
2641     register I32 j;
2642     I32 del;
2643     I32 complement;
2644     I32 squash;
2645     I32 grows = 0;
2646     register short *tbl;
2647
2648     PL_hints |= HINT_BLOCK_SCOPE;
2649     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2650     del         = o->op_private & OPpTRANS_DELETE;
2651     squash      = o->op_private & OPpTRANS_SQUASH;
2652
2653     if (SvUTF8(tstr))
2654         o->op_private |= OPpTRANS_FROM_UTF;
2655
2656     if (SvUTF8(rstr))
2657         o->op_private |= OPpTRANS_TO_UTF;
2658
2659     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2660         SV* listsv = newSVpvn("# comment\n",10);
2661         SV* transv = 0;
2662         U8* tend = t + tlen;
2663         U8* rend = r + rlen;
2664         STRLEN ulen;
2665         U32 tfirst = 1;
2666         U32 tlast = 0;
2667         I32 tdiff;
2668         U32 rfirst = 1;
2669         U32 rlast = 0;
2670         I32 rdiff;
2671         I32 diff;
2672         I32 none = 0;
2673         U32 max = 0;
2674         I32 bits;
2675         I32 havefinal = 0;
2676         U32 final = 0;
2677         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2678         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2679         U8* tsave = NULL;
2680         U8* rsave = NULL;
2681
2682         if (!from_utf) {
2683             STRLEN len = tlen;
2684             tsave = t = bytes_to_utf8(t, &len);
2685             tend = t + len;
2686         }
2687         if (!to_utf && rlen) {
2688             STRLEN len = rlen;
2689             rsave = r = bytes_to_utf8(r, &len);
2690             rend = r + len;
2691         }
2692
2693 /* There are several snags with this code on EBCDIC:
2694    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2695    2. scan_const() in toke.c has encoded chars in native encoding which makes
2696       ranges at least in EBCDIC 0..255 range the bottom odd.
2697 */
2698
2699         if (complement) {
2700             U8 tmpbuf[UTF8_MAXLEN+1];
2701             UV *cp;
2702             UV nextmin = 0;
2703             New(1109, cp, 2*tlen, UV);
2704             i = 0;
2705             transv = newSVpvn("",0);
2706             while (t < tend) {
2707                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2708                 t += ulen;
2709                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2710                     t++;
2711                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2712                     t += ulen;
2713                 }
2714                 else {
2715                  cp[2*i+1] = cp[2*i];
2716                 }
2717                 i++;
2718             }
2719             qsort(cp, i, 2*sizeof(UV), uvcompare);
2720             for (j = 0; j < i; j++) {
2721                 UV  val = cp[2*j];
2722                 diff = val - nextmin;
2723                 if (diff > 0) {
2724                     t = uvuni_to_utf8(tmpbuf,nextmin);
2725                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2726                     if (diff > 1) {
2727                         U8  range_mark = UTF_TO_NATIVE(0xff);
2728                         t = uvuni_to_utf8(tmpbuf, val - 1);
2729                         sv_catpvn(transv, (char *)&range_mark, 1);
2730                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2731                     }
2732                 }
2733                 val = cp[2*j+1];
2734                 if (val >= nextmin)
2735                     nextmin = val + 1;
2736             }
2737             t = uvuni_to_utf8(tmpbuf,nextmin);
2738             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2739             {
2740                 U8 range_mark = UTF_TO_NATIVE(0xff);
2741                 sv_catpvn(transv, (char *)&range_mark, 1);
2742             }
2743             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2744             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2745             t = (U8*)SvPVX(transv);
2746             tlen = SvCUR(transv);
2747             tend = t + tlen;
2748             Safefree(cp);
2749         }
2750         else if (!rlen && !del) {
2751             r = t; rlen = tlen; rend = tend;
2752         }
2753         if (!squash) {
2754                 if ((!rlen && !del) || t == r ||
2755                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2756                 {
2757                     o->op_private |= OPpTRANS_IDENTICAL;
2758                 }
2759         }
2760
2761         while (t < tend || tfirst <= tlast) {
2762             /* see if we need more "t" chars */
2763             if (tfirst > tlast) {
2764                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2765                 t += ulen;
2766                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2767                     t++;
2768                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2769                     t += ulen;
2770                 }
2771                 else
2772                     tlast = tfirst;
2773             }
2774
2775             /* now see if we need more "r" chars */
2776             if (rfirst > rlast) {
2777                 if (r < rend) {
2778                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2779                     r += ulen;
2780                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2781                         r++;
2782                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2783                         r += ulen;
2784                     }
2785                     else
2786                         rlast = rfirst;
2787                 }
2788                 else {
2789                     if (!havefinal++)
2790                         final = rlast;
2791                     rfirst = rlast = 0xffffffff;
2792                 }
2793             }
2794
2795             /* now see which range will peter our first, if either. */
2796             tdiff = tlast - tfirst;
2797             rdiff = rlast - rfirst;
2798
2799             if (tdiff <= rdiff)
2800                 diff = tdiff;
2801             else
2802                 diff = rdiff;
2803
2804             if (rfirst == 0xffffffff) {
2805                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2806                 if (diff > 0)
2807                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2808                                    (long)tfirst, (long)tlast);
2809                 else
2810                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2811             }
2812             else {
2813                 if (diff > 0)
2814                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2815                                    (long)tfirst, (long)(tfirst + diff),
2816                                    (long)rfirst);
2817                 else
2818                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2819                                    (long)tfirst, (long)rfirst);
2820
2821                 if (rfirst + diff > max)
2822                     max = rfirst + diff;
2823                 if (!grows)
2824                     grows = (tfirst < rfirst &&
2825                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2826                 rfirst += diff + 1;
2827             }
2828             tfirst += diff + 1;
2829         }
2830
2831         none = ++max;
2832         if (del)
2833             del = ++max;
2834
2835         if (max > 0xffff)
2836             bits = 32;
2837         else if (max > 0xff)
2838             bits = 16;
2839         else
2840             bits = 8;
2841
2842         Safefree(cPVOPo->op_pv);
2843         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2844         SvREFCNT_dec(listsv);
2845         if (transv)
2846             SvREFCNT_dec(transv);
2847
2848         if (!del && havefinal && rlen)
2849             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2850                            newSVuv((UV)final), 0);
2851
2852         if (grows)
2853             o->op_private |= OPpTRANS_GROWS;
2854
2855         if (tsave)
2856             Safefree(tsave);
2857         if (rsave)
2858             Safefree(rsave);
2859
2860         op_free(expr);
2861         op_free(repl);
2862         return o;
2863     }
2864
2865     tbl = (short*)cPVOPo->op_pv;
2866     if (complement) {
2867         Zero(tbl, 256, short);
2868         for (i = 0; i < tlen; i++)
2869             tbl[t[i]] = -1;
2870         for (i = 0, j = 0; i < 256; i++) {
2871             if (!tbl[i]) {
2872                 if (j >= rlen) {
2873                     if (del)
2874                         tbl[i] = -2;
2875                     else if (rlen)
2876                         tbl[i] = r[j-1];
2877                     else
2878                         tbl[i] = i;
2879                 }
2880                 else {
2881                     if (i < 128 && r[j] >= 128)
2882                         grows = 1;
2883                     tbl[i] = r[j++];
2884                 }
2885             }
2886         }
2887         if (!del) {
2888             if (!rlen) {
2889                 j = rlen;
2890                 if (!squash)
2891                     o->op_private |= OPpTRANS_IDENTICAL;
2892             }
2893             else if (j >= rlen)
2894                 j = rlen - 1;
2895             else
2896                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2897             tbl[0x100] = rlen - j;
2898             for (i=0; i < rlen - j; i++)
2899                 tbl[0x101+i] = r[j+i];
2900         }
2901     }
2902     else {
2903         if (!rlen && !del) {
2904             r = t; rlen = tlen;
2905             if (!squash)
2906                 o->op_private |= OPpTRANS_IDENTICAL;
2907         }
2908         for (i = 0; i < 256; i++)
2909             tbl[i] = -1;
2910         for (i = 0, j = 0; i < tlen; i++,j++) {
2911             if (j >= rlen) {
2912                 if (del) {
2913                     if (tbl[t[i]] == -1)
2914                         tbl[t[i]] = -2;
2915                     continue;
2916                 }
2917                 --j;
2918             }
2919             if (tbl[t[i]] == -1) {
2920                 if (t[i] < 128 && r[j] >= 128)
2921                     grows = 1;
2922                 tbl[t[i]] = r[j];
2923             }
2924         }
2925     }
2926     if (grows)
2927         o->op_private |= OPpTRANS_GROWS;
2928     op_free(expr);
2929     op_free(repl);
2930
2931     return o;
2932 }
2933
2934 OP *
2935 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2936 {
2937     PMOP *pmop;
2938
2939     NewOp(1101, pmop, 1, PMOP);
2940     pmop->op_type = type;
2941     pmop->op_ppaddr = PL_ppaddr[type];
2942     pmop->op_flags = flags;
2943     pmop->op_private = 0 | (flags >> 8);
2944
2945     if (PL_hints & HINT_RE_TAINT)
2946         pmop->op_pmpermflags |= PMf_RETAINT;
2947     if (PL_hints & HINT_LOCALE)
2948         pmop->op_pmpermflags |= PMf_LOCALE;
2949     pmop->op_pmflags = pmop->op_pmpermflags;
2950
2951  #ifdef USE_ITHREADS
2952         {
2953                 SV* repointer = newSViv(0);
2954                 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2955                 pmop->op_pmoffset = av_len(PL_regex_padav);
2956                 PL_regex_pad = AvARRAY(PL_regex_padav);
2957         }
2958  #endif
2959
2960         /* link into pm list */
2961     if (type != OP_TRANS && PL_curstash) {
2962         pmop->op_pmnext = HvPMROOT(PL_curstash);
2963         HvPMROOT(PL_curstash) = pmop;
2964         PmopSTASH_set(pmop,PL_curstash);
2965     }
2966
2967     return (OP*)pmop;
2968 }
2969
2970 OP *
2971 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2972 {
2973     PMOP *pm;
2974     LOGOP *rcop;
2975     I32 repl_has_vars = 0;
2976
2977     if (o->op_type == OP_TRANS)
2978         return pmtrans(o, expr, repl);
2979
2980     PL_hints |= HINT_BLOCK_SCOPE;
2981     pm = (PMOP*)o;
2982
2983     if (expr->op_type == OP_CONST) {
2984         STRLEN plen;
2985         SV *pat = ((SVOP*)expr)->op_sv;
2986         char *p = SvPV(pat, plen);
2987         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2988             sv_setpvn(pat, "\\s+", 3);
2989             p = SvPV(pat, plen);
2990             pm->op_pmflags |= PMf_SKIPWHITE;
2991         }
2992         if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2993             pm->op_pmdynflags |= PMdf_UTF8;
2994         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2995         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2996             pm->op_pmflags |= PMf_WHITE;
2997         op_free(expr);
2998     }
2999     else {
3000         if (PL_hints & HINT_UTF8)
3001             pm->op_pmdynflags |= PMdf_UTF8;
3002         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3003             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3004                             ? OP_REGCRESET
3005                             : OP_REGCMAYBE),0,expr);
3006
3007         NewOp(1101, rcop, 1, LOGOP);
3008         rcop->op_type = OP_REGCOMP;
3009         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3010         rcop->op_first = scalar(expr);
3011         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3012                            ? (OPf_SPECIAL | OPf_KIDS)
3013                            : OPf_KIDS);
3014         rcop->op_private = 1;
3015         rcop->op_other = o;
3016
3017         /* establish postfix order */
3018         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3019             LINKLIST(expr);
3020             rcop->op_next = expr;
3021             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3022         }
3023         else {
3024             rcop->op_next = LINKLIST(expr);
3025             expr->op_next = (OP*)rcop;
3026         }
3027
3028         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3029     }
3030
3031     if (repl) {
3032         OP *curop;
3033         if (pm->op_pmflags & PMf_EVAL) {
3034             curop = 0;
3035             if (CopLINE(PL_curcop) < PL_multi_end)
3036                 CopLINE_set(PL_curcop, PL_multi_end);
3037         }
3038 #ifdef USE_THREADS
3039         else if (repl->op_type == OP_THREADSV
3040                  && strchr("&`'123456789+",
3041                            PL_threadsv_names[repl->op_targ]))
3042         {
3043             curop = 0;
3044         }
3045 #endif /* USE_THREADS */
3046         else if (repl->op_type == OP_CONST)
3047             curop = repl;
3048         else {
3049             OP *lastop = 0;
3050             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3051                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3052 #ifdef USE_THREADS
3053                     if (curop->op_type == OP_THREADSV) {
3054                         repl_has_vars = 1;
3055                         if (strchr("&`'123456789+", curop->op_private))
3056                             break;
3057                     }
3058 #else
3059                     if (curop->op_type == OP_GV) {
3060                         GV *gv = cGVOPx_gv(curop);
3061                         repl_has_vars = 1;
3062                         if (strchr("&`'123456789+", *GvENAME(gv)))
3063                             break;
3064                     }
3065 #endif /* USE_THREADS */
3066                     else if (curop->op_type == OP_RV2CV)
3067                         break;
3068                     else if (curop->op_type == OP_RV2SV ||
3069                              curop->op_type == OP_RV2AV ||
3070                              curop->op_type == OP_RV2HV ||
3071                              curop->op_type == OP_RV2GV) {
3072                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3073                             break;
3074                     }
3075                     else if (curop->op_type == OP_PADSV ||
3076                              curop->op_type == OP_PADAV ||
3077                              curop->op_type == OP_PADHV ||
3078                              curop->op_type == OP_PADANY) {
3079                         repl_has_vars = 1;
3080                     }
3081                     else if (curop->op_type == OP_PUSHRE)
3082                         ; /* Okay here, dangerous in newASSIGNOP */
3083                     else
3084                         break;
3085                 }
3086                 lastop = curop;
3087             }
3088         }
3089         if (curop == repl
3090             && !(repl_has_vars
3091                  && (!PM_GETRE(pm)
3092                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3093             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3094             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3095             prepend_elem(o->op_type, scalar(repl), o);
3096         }
3097         else {
3098             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3099                 pm->op_pmflags |= PMf_MAYBE_CONST;
3100                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3101             }
3102             NewOp(1101, rcop, 1, LOGOP);
3103             rcop->op_type = OP_SUBSTCONT;
3104             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3105             rcop->op_first = scalar(repl);
3106             rcop->op_flags |= OPf_KIDS;
3107             rcop->op_private = 1;
3108             rcop->op_other = o;
3109
3110             /* establish postfix order */
3111             rcop->op_next = LINKLIST(repl);
3112             repl->op_next = (OP*)rcop;
3113
3114             pm->op_pmreplroot = scalar((OP*)rcop);
3115             pm->op_pmreplstart = LINKLIST(rcop);
3116             rcop->op_next = 0;
3117         }
3118     }
3119
3120     return (OP*)pm;
3121 }
3122
3123 OP *
3124 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3125 {
3126     SVOP *svop;
3127     NewOp(1101, svop, 1, SVOP);
3128     svop->op_type = type;
3129     svop->op_ppaddr = PL_ppaddr[type];
3130     svop->op_sv = sv;
3131     svop->op_next = (OP*)svop;
3132     svop->op_flags = flags;
3133     if (PL_opargs[type] & OA_RETSCALAR)
3134         scalar((OP*)svop);
3135     if (PL_opargs[type] & OA_TARGET)
3136         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3137     return CHECKOP(type, svop);
3138 }
3139
3140 OP *
3141 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3142 {
3143     PADOP *padop;
3144     NewOp(1101, padop, 1, PADOP);
3145     padop->op_type = type;
3146     padop->op_ppaddr = PL_ppaddr[type];
3147     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3148     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3149     PL_curpad[padop->op_padix] = sv;
3150     SvPADTMP_on(sv);
3151     padop->op_next = (OP*)padop;
3152     padop->op_flags = flags;
3153     if (PL_opargs[type] & OA_RETSCALAR)
3154         scalar((OP*)padop);
3155     if (PL_opargs[type] & OA_TARGET)
3156         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3157     return CHECKOP(type, padop);
3158 }
3159
3160 OP *
3161 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3162 {
3163 #ifdef USE_ITHREADS
3164     GvIN_PAD_on(gv);
3165     return newPADOP(type, flags, SvREFCNT_inc(gv));
3166 #else
3167     return newSVOP(type, flags, SvREFCNT_inc(gv));
3168 #endif
3169 }
3170
3171 OP *
3172 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3173 {
3174     PVOP *pvop;
3175     NewOp(1101, pvop, 1, PVOP);
3176     pvop->op_type = type;
3177     pvop->op_ppaddr = PL_ppaddr[type];
3178     pvop->op_pv = pv;
3179     pvop->op_next = (OP*)pvop;
3180     pvop->op_flags = flags;
3181     if (PL_opargs[type] & OA_RETSCALAR)
3182         scalar((OP*)pvop);
3183     if (PL_opargs[type] & OA_TARGET)
3184         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3185     return CHECKOP(type, pvop);
3186 }
3187
3188 void
3189 Perl_package(pTHX_ OP *o)
3190 {
3191     SV *sv;
3192
3193     save_hptr(&PL_curstash);
3194     save_item(PL_curstname);
3195     if (o) {
3196         STRLEN len;
3197         char *name;
3198         sv = cSVOPo->op_sv;
3199         name = SvPV(sv, len);
3200         PL_curstash = gv_stashpvn(name,len,TRUE);
3201         sv_setpvn(PL_curstname, name, len);
3202         op_free(o);
3203     }
3204     else {
3205         deprecate("\"package\" with no arguments");
3206         sv_setpv(PL_curstname,"<none>");
3207         PL_curstash = Nullhv;
3208     }
3209     PL_hints |= HINT_BLOCK_SCOPE;
3210     PL_copline = NOLINE;
3211     PL_expect = XSTATE;
3212 }
3213
3214 void
3215 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3216 {
3217     OP *pack;
3218     OP *imop;
3219     OP *veop;
3220
3221     if (id->op_type != OP_CONST)
3222         Perl_croak(aTHX_ "Module name must be constant");
3223
3224     veop = Nullop;
3225
3226     if (version != Nullop) {
3227         SV *vesv = ((SVOP*)version)->op_sv;
3228
3229         if (arg == Nullop && !SvNIOKp(vesv)) {
3230             arg = version;
3231         }
3232         else {
3233             OP *pack;
3234             SV *meth;
3235
3236             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3237                 Perl_croak(aTHX_ "Version number must be constant number");
3238
3239             /* Make copy of id so we don't free it twice */
3240             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3241
3242             /* Fake up a method call to VERSION */
3243             meth = newSVpvn("VERSION",7);
3244             sv_upgrade(meth, SVt_PVIV);
3245             (void)SvIOK_on(meth);
3246             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3247             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3248                             append_elem(OP_LIST,
3249                                         prepend_elem(OP_LIST, pack, list(version)),
3250                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3251         }
3252     }
3253
3254     /* Fake up an import/unimport */
3255     if (arg && arg->op_type == OP_STUB)
3256         imop = arg;             /* no import on explicit () */
3257     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3258         imop = Nullop;          /* use 5.0; */
3259     }
3260     else {
3261         SV *meth;
3262
3263         /* Make copy of id so we don't free it twice */
3264         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3265
3266         /* Fake up a method call to import/unimport */
3267         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3268         sv_upgrade(meth, SVt_PVIV);
3269         (void)SvIOK_on(meth);
3270         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3271         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3272                        append_elem(OP_LIST,
3273                                    prepend_elem(OP_LIST, pack, list(arg)),
3274                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3275     }
3276
3277     /* Fake up the BEGIN {}, which does its thing immediately. */
3278     newATTRSUB(floor,
3279         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3280         Nullop,
3281         Nullop,
3282         append_elem(OP_LINESEQ,
3283             append_elem(OP_LINESEQ,
3284                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3285                 newSTATEOP(0, Nullch, veop)),
3286             newSTATEOP(0, Nullch, imop) ));
3287
3288     PL_hints |= HINT_BLOCK_SCOPE;
3289     PL_copline = NOLINE;
3290     PL_expect = XSTATE;
3291 }
3292
3293 /*
3294 =for apidoc load_module
3295
3296 Loads the module whose name is pointed to by the string part of name.
3297 Note that the actual module name, not its filename, should be given.
3298 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3299 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3300 (or 0 for no flags). ver, if specified, provides version semantics
3301 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3302 arguments can be used to specify arguments to the module's import()
3303 method, similar to C<use Foo::Bar VERSION LIST>.
3304
3305 =cut */
3306
3307 void
3308 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3309 {
3310     va_list args;
3311     va_start(args, ver);
3312     vload_module(flags, name, ver, &args);
3313     va_end(args);
3314 }
3315
3316 #ifdef PERL_IMPLICIT_CONTEXT
3317 void
3318 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3319 {
3320     dTHX;
3321     va_list args;
3322     va_start(args, ver);
3323     vload_module(flags, name, ver, &args);
3324     va_end(args);
3325 }
3326 #endif
3327
3328 void
3329 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3330 {
3331     OP *modname, *veop, *imop;
3332
3333     modname = newSVOP(OP_CONST, 0, name);
3334     modname->op_private |= OPpCONST_BARE;
3335     if (ver) {
3336         veop = newSVOP(OP_CONST, 0, ver);
3337     }
3338     else
3339         veop = Nullop;
3340     if (flags & PERL_LOADMOD_NOIMPORT) {
3341         imop = sawparens(newNULLLIST());
3342     }
3343     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3344         imop = va_arg(*args, OP*);
3345     }
3346     else {
3347         SV *sv;
3348         imop = Nullop;
3349         sv = va_arg(*args, SV*);
3350         while (sv) {
3351             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3352             sv = va_arg(*args, SV*);
3353         }
3354     }
3355     {
3356         line_t ocopline = PL_copline;
3357         int oexpect = PL_expect;
3358
3359         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3360                 veop, modname, imop);
3361         PL_expect = oexpect;
3362         PL_copline = ocopline;
3363     }
3364 }
3365
3366 OP *
3367 Perl_dofile(pTHX_ OP *term)
3368 {
3369     OP *doop;
3370     GV *gv;
3371
3372     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3373     if (!(gv && GvIMPORTED_CV(gv)))
3374         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3375
3376     if (gv && GvIMPORTED_CV(gv)) {
3377         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3378                                append_elem(OP_LIST, term,
3379                                            scalar(newUNOP(OP_RV2CV, 0,
3380                                                           newGVOP(OP_GV, 0,
3381                                                                   gv))))));
3382     }
3383     else {
3384         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3385     }
3386     return doop;
3387 }
3388
3389 OP *
3390 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3391 {
3392     return newBINOP(OP_LSLICE, flags,
3393             list(force_list(subscript)),
3394             list(force_list(listval)) );
3395 }
3396
3397 STATIC I32
3398 S_list_assignment(pTHX_ register OP *o)
3399 {
3400     if (!o)
3401         return TRUE;
3402
3403     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3404         o = cUNOPo->op_first;
3405
3406     if (o->op_type == OP_COND_EXPR) {
3407         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3408         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3409
3410         if (t && f)
3411             return TRUE;
3412         if (t || f)
3413             yyerror("Assignment to both a list and a scalar");
3414         return FALSE;
3415     }
3416
3417     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3418         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3419         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3420         return TRUE;
3421
3422     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3423         return TRUE;
3424
3425     if (o->op_type == OP_RV2SV)
3426         return FALSE;
3427
3428     return FALSE;
3429 }
3430
3431 OP *
3432 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3433 {
3434     OP *o;
3435
3436     if (optype) {
3437         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3438             return newLOGOP(optype, 0,
3439                 mod(scalar(left), optype),
3440                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3441         }
3442         else {
3443             return newBINOP(optype, OPf_STACKED,
3444                 mod(scalar(left), optype), scalar(right));
3445         }
3446     }
3447
3448     if (list_assignment(left)) {
3449         OP *curop;
3450
3451         PL_modcount = 0;
3452         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3453         left = mod(left, OP_AASSIGN);
3454         if (PL_eval_start)
3455             PL_eval_start = 0;
3456         else {
3457             op_free(left);
3458             op_free(right);
3459             return Nullop;
3460         }
3461         curop = list(force_list(left));
3462         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3463         o->op_private = 0 | (flags >> 8);
3464         for (curop = ((LISTOP*)curop)->op_first;
3465              curop; curop = curop->op_sibling)
3466         {
3467             if (curop->op_type == OP_RV2HV &&
3468                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3469                 o->op_private |= OPpASSIGN_HASH;
3470                 break;
3471             }
3472         }
3473         if (!(left->op_private & OPpLVAL_INTRO)) {
3474             OP *lastop = o;
3475             PL_generation++;
3476             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3477                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3478                     if (curop->op_type == OP_GV) {
3479                         GV *gv = cGVOPx_gv(curop);
3480                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3481                             break;
3482                         SvCUR(gv) = PL_generation;
3483                     }
3484                     else if (curop->op_type == OP_PADSV ||
3485                              curop->op_type == OP_PADAV ||
3486                              curop->op_type == OP_PADHV ||
3487                              curop->op_type == OP_PADANY) {
3488                         SV **svp = AvARRAY(PL_comppad_name);
3489                         SV *sv = svp[curop->op_targ];
3490                         if (SvCUR(sv) == PL_generation)
3491                             break;
3492                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3493                     }
3494                     else if (curop->op_type == OP_RV2CV)
3495                         break;
3496                     else if (curop->op_type == OP_RV2SV ||
3497                              curop->op_type == OP_RV2AV ||
3498                              curop->op_type == OP_RV2HV ||
3499                              curop->op_type == OP_RV2GV) {
3500                         if (lastop->op_type != OP_GV)   /* funny deref? */
3501                             break;
3502                     }
3503                     else if (curop->op_type == OP_PUSHRE) {
3504                         if (((PMOP*)curop)->op_pmreplroot) {
3505 #ifdef USE_ITHREADS
3506                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3507 #else
3508                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3509 #endif
3510                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3511                                 break;
3512                             SvCUR(gv) = PL_generation;
3513                         }
3514                     }
3515                     else
3516                         break;
3517                 }
3518                 lastop = curop;
3519             }
3520             if (curop != o)
3521                 o->op_private |= OPpASSIGN_COMMON;
3522         }
3523         if (right && right->op_type == OP_SPLIT) {
3524             OP* tmpop;
3525             if ((tmpop = ((LISTOP*)right)->op_first) &&
3526                 tmpop->op_type == OP_PUSHRE)
3527             {
3528                 PMOP *pm = (PMOP*)tmpop;
3529                 if (left->op_type == OP_RV2AV &&
3530                     !(left->op_private & OPpLVAL_INTRO) &&
3531                     !(o->op_private & OPpASSIGN_COMMON) )
3532                 {
3533                     tmpop = ((UNOP*)left)->op_first;
3534                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3535 #ifdef USE_ITHREADS
3536                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3537                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3538 #else
3539                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3540                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3541 #endif
3542                         pm->op_pmflags |= PMf_ONCE;
3543                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3544                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3545                         tmpop->op_sibling = Nullop;     /* don't free split */
3546                         right->op_next = tmpop->op_next;  /* fix starting loc */
3547                         op_free(o);                     /* blow off assign */
3548                         right->op_flags &= ~OPf_WANT;
3549                                 /* "I don't know and I don't care." */
3550                         return right;
3551                     }
3552                 }
3553                 else {
3554                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3555                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3556                     {
3557                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3558                         if (SvIVX(sv) == 0)
3559                             sv_setiv(sv, PL_modcount+1);
3560                     }
3561                 }
3562             }
3563         }
3564         return o;
3565     }
3566     if (!right)
3567         right = newOP(OP_UNDEF, 0);
3568     if (right->op_type == OP_READLINE) {
3569         right->op_flags |= OPf_STACKED;
3570         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3571     }
3572     else {
3573         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3574         o = newBINOP(OP_SASSIGN, flags,
3575             scalar(right), mod(scalar(left), OP_SASSIGN) );
3576         if (PL_eval_start)
3577             PL_eval_start = 0;
3578         else {
3579             op_free(o);
3580             return Nullop;
3581         }
3582     }
3583     return o;
3584 }
3585
3586 OP *
3587 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3588 {
3589     U32 seq = intro_my();
3590     register COP *cop;
3591
3592     NewOp(1101, cop, 1, COP);
3593     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3594         cop->op_type = OP_DBSTATE;
3595         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3596     }
3597     else {
3598         cop->op_type = OP_NEXTSTATE;
3599         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3600     }
3601     cop->op_flags = flags;
3602     cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3603 #ifdef NATIVE_HINTS
3604     cop->op_private |= NATIVE_HINTS;
3605 #endif
3606     PL_compiling.op_private = cop->op_private;
3607     cop->op_next = (OP*)cop;
3608
3609     if (label) {
3610         cop->cop_label = label;
3611         PL_hints |= HINT_BLOCK_SCOPE;
3612     }
3613     cop->cop_seq = seq;
3614     cop->cop_arybase = PL_curcop->cop_arybase;
3615     if (specialWARN(PL_curcop->cop_warnings))
3616         cop->cop_warnings = PL_curcop->cop_warnings ;
3617     else
3618         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3619     if (specialCopIO(PL_curcop->cop_io))
3620         cop->cop_io = PL_curcop->cop_io;
3621     else
3622         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3623
3624
3625     if (PL_copline == NOLINE)
3626         CopLINE_set(cop, CopLINE(PL_curcop));
3627     else {
3628         CopLINE_set(cop, PL_copline);
3629         PL_copline = NOLINE;
3630     }
3631 #ifdef USE_ITHREADS
3632     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3633 #else
3634     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3635 #endif
3636     CopSTASH_set(cop, PL_curstash);
3637
3638     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3639         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3640         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3641             (void)SvIOK_on(*svp);
3642             SvIVX(*svp) = PTR2IV(cop);
3643         }
3644     }
3645
3646     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3647 }
3648
3649 /* "Introduce" my variables to visible status. */
3650 U32
3651 Perl_intro_my(pTHX)
3652 {
3653     SV **svp;
3654     SV *sv;
3655     I32 i;
3656
3657     if (! PL_min_intro_pending)
3658         return PL_cop_seqmax;
3659
3660     svp = AvARRAY(PL_comppad_name);
3661     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3662         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3663             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3664             SvNVX(sv) = (NV)PL_cop_seqmax;
3665         }
3666     }
3667     PL_min_intro_pending = 0;
3668     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3669     return PL_cop_seqmax++;
3670 }
3671
3672 OP *
3673 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3674 {
3675     return new_logop(type, flags, &first, &other);
3676 }
3677
3678 STATIC OP *
3679 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3680 {
3681     LOGOP *logop;
3682     OP *o;
3683     OP *first = *firstp;
3684     OP *other = *otherp;
3685
3686     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3687         return newBINOP(type, flags, scalar(first), scalar(other));
3688
3689     scalarboolean(first);
3690     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3691     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3692         if (type == OP_AND || type == OP_OR) {
3693             if (type == OP_AND)
3694                 type = OP_OR;
3695             else
3696                 type = OP_AND;
3697             o = first;
3698             first = *firstp = cUNOPo->op_first;
3699             if (o->op_next)
3700                 first->op_next = o->op_next;
3701             cUNOPo->op_first = Nullop;
3702             op_free(o);
3703         }
3704     }
3705     if (first->op_type == OP_CONST) {
3706         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3707             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3708         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3709             op_free(first);
3710             *firstp = Nullop;
3711             return other;
3712         }
3713         else {
3714             op_free(other);
3715             *otherp = Nullop;
3716             return first;
3717         }
3718     }
3719     else if (first->op_type == OP_WANTARRAY) {
3720         if (type == OP_AND)
3721             list(other);
3722         else
3723             scalar(other);
3724     }
3725     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3726         OP *k1 = ((UNOP*)first)->op_first;
3727         OP *k2 = k1->op_sibling;
3728         OPCODE warnop = 0;
3729         switch (first->op_type)
3730         {
3731         case OP_NULL:
3732             if (k2 && k2->op_type == OP_READLINE
3733                   && (k2->op_flags & OPf_STACKED)
3734                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3735             {
3736                 warnop = k2->op_type;
3737             }
3738             break;
3739
3740         case OP_SASSIGN:
3741             if (k1->op_type == OP_READDIR
3742                   || k1->op_type == OP_GLOB
3743                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3744                   || k1->op_type == OP_EACH)
3745             {
3746                 warnop = ((k1->op_type == OP_NULL)
3747                           ? k1->op_targ : k1->op_type);
3748             }
3749             break;
3750         }
3751         if (warnop) {
3752             line_t oldline = CopLINE(PL_curcop);
3753             CopLINE_set(PL_curcop, PL_copline);
3754             Perl_warner(aTHX_ WARN_MISC,
3755                  "Value of %s%s can be \"0\"; test with defined()",
3756                  PL_op_desc[warnop],
3757                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3758                   ? " construct" : "() operator"));
3759             CopLINE_set(PL_curcop, oldline);
3760         }
3761     }
3762
3763     if (!other)
3764         return first;
3765
3766     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3767         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3768
3769     NewOp(1101, logop, 1, LOGOP);
3770
3771     logop->op_type = type;
3772     logop->op_ppaddr = PL_ppaddr[type];
3773     logop->op_first = first;
3774     logop->op_flags = flags | OPf_KIDS;
3775     logop->op_other = LINKLIST(other);
3776     logop->op_private = 1 | (flags >> 8);
3777
3778     /* establish postfix order */
3779     logop->op_next = LINKLIST(first);
3780     first->op_next = (OP*)logop;
3781     first->op_sibling = other;
3782
3783     o = newUNOP(OP_NULL, 0, (OP*)logop);
3784     other->op_next = o;
3785
3786     return o;
3787 }
3788
3789 OP *
3790 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3791 {
3792     LOGOP *logop;
3793     OP *start;
3794     OP *o;
3795
3796     if (!falseop)
3797         return newLOGOP(OP_AND, 0, first, trueop);
3798     if (!trueop)
3799         return newLOGOP(OP_OR, 0, first, falseop);
3800
3801     scalarboolean(first);
3802     if (first->op_type == OP_CONST) {
3803         if (SvTRUE(((SVOP*)first)->op_sv)) {
3804             op_free(first);
3805             op_free(falseop);
3806             return trueop;
3807         }
3808         else {
3809             op_free(first);
3810             op_free(trueop);
3811             return falseop;
3812         }
3813     }
3814     else if (first->op_type == OP_WANTARRAY) {
3815         list(trueop);
3816         scalar(falseop);
3817     }
3818     NewOp(1101, logop, 1, LOGOP);
3819     logop->op_type = OP_COND_EXPR;
3820     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3821     logop->op_first = first;
3822     logop->op_flags = flags | OPf_KIDS;
3823     logop->op_private = 1 | (flags >> 8);
3824     logop->op_other = LINKLIST(trueop);
3825     logop->op_next = LINKLIST(falseop);
3826
3827
3828     /* establish postfix order */
3829     start = LINKLIST(first);
3830     first->op_next = (OP*)logop;
3831
3832     first->op_sibling = trueop;
3833     trueop->op_sibling = falseop;
3834     o = newUNOP(OP_NULL, 0, (OP*)logop);
3835
3836     trueop->op_next = falseop->op_next = o;
3837
3838     o->op_next = start;
3839     return o;
3840 }
3841
3842 OP *
3843 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3844 {
3845     LOGOP *range;
3846     OP *flip;
3847     OP *flop;
3848     OP *leftstart;
3849     OP *o;
3850
3851     NewOp(1101, range, 1, LOGOP);
3852
3853     range->op_type = OP_RANGE;
3854     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3855     range->op_first = left;
3856     range->op_flags = OPf_KIDS;
3857     leftstart = LINKLIST(left);
3858     range->op_other = LINKLIST(right);
3859     range->op_private = 1 | (flags >> 8);
3860
3861     left->op_sibling = right;
3862
3863     range->op_next = (OP*)range;
3864     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3865     flop = newUNOP(OP_FLOP, 0, flip);
3866     o = newUNOP(OP_NULL, 0, flop);
3867     linklist(flop);
3868     range->op_next = leftstart;
3869
3870     left->op_next = flip;
3871     right->op_next = flop;
3872
3873     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3874     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3875     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3876     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3877
3878     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3879     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3880
3881     flip->op_next = o;
3882     if (!flip->op_private || !flop->op_private)
3883         linklist(o);            /* blow off optimizer unless constant */
3884
3885     return o;
3886 }
3887
3888 OP *
3889 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3890 {
3891     OP* listop;
3892     OP* o;
3893     int once = block && block->op_flags & OPf_SPECIAL &&
3894       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3895
3896     if (expr) {
3897         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3898             return block;       /* do {} while 0 does once */
3899         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3900             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3901             expr = newUNOP(OP_DEFINED, 0,
3902                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3903         } else if (expr->op_flags & OPf_KIDS) {
3904             OP *k1 = ((UNOP*)expr)->op_first;
3905             OP *k2 = (k1) ? k1->op_sibling : NULL;
3906             switch (expr->op_type) {
3907               case OP_NULL:
3908                 if (k2 && k2->op_type == OP_READLINE
3909                       && (k2->op_flags & OPf_STACKED)
3910                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3911                     expr = newUNOP(OP_DEFINED, 0, expr);
3912                 break;
3913
3914               case OP_SASSIGN:
3915                 if (k1->op_type == OP_READDIR
3916                       || k1->op_type == OP_GLOB
3917                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3918                       || k1->op_type == OP_EACH)
3919                     expr = newUNOP(OP_DEFINED, 0, expr);
3920                 break;
3921             }
3922         }
3923     }
3924
3925     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3926     o = new_logop(OP_AND, 0, &expr, &listop);
3927
3928     if (listop)
3929         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3930
3931     if (once && o != listop)
3932         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3933
3934     if (o == listop)
3935         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3936
3937     o->op_flags |= flags;
3938     o = scope(o);
3939     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3940     return o;
3941 }
3942
3943 OP *
3944 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3945 {
3946     OP *redo;
3947     OP *next = 0;
3948     OP *listop;
3949     OP *o;
3950     U8 loopflags = 0;
3951
3952     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3953                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3954         expr = newUNOP(OP_DEFINED, 0,
3955             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3956     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3957         OP *k1 = ((UNOP*)expr)->op_first;
3958         OP *k2 = (k1) ? k1->op_sibling : NULL;
3959         switch (expr->op_type) {
3960           case OP_NULL:
3961             if (k2 && k2->op_type == OP_READLINE
3962                   && (k2->op_flags & OPf_STACKED)
3963                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3964                 expr = newUNOP(OP_DEFINED, 0, expr);
3965             break;
3966
3967           case OP_SASSIGN:
3968             if (k1->op_type == OP_READDIR
3969                   || k1->op_type == OP_GLOB
3970                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3971                   || k1->op_type == OP_EACH)
3972                 expr = newUNOP(OP_DEFINED, 0, expr);
3973             break;
3974         }
3975     }
3976
3977     if (!block)
3978         block = newOP(OP_NULL, 0);
3979     else if (cont) {
3980         block = scope(block);
3981     }
3982
3983     if (cont) {
3984         next = LINKLIST(cont);
3985     }
3986     if (expr) {
3987         OP *unstack = newOP(OP_UNSTACK, 0);
3988         if (!next)
3989             next = unstack;
3990         cont = append_elem(OP_LINESEQ, cont, unstack);
3991         if ((line_t)whileline != NOLINE) {
3992             PL_copline = whileline;
3993             cont = append_elem(OP_LINESEQ, cont,
3994                                newSTATEOP(0, Nullch, Nullop));
3995         }
3996     }
3997
3998     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3999     redo = LINKLIST(listop);
4000
4001     if (expr) {
4002         PL_copline = whileline;
4003         scalar(listop);
4004         o = new_logop(OP_AND, 0, &expr, &listop);
4005         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4006             op_free(expr);              /* oops, it's a while (0) */
4007             op_free((OP*)loop);
4008             return Nullop;              /* listop already freed by new_logop */
4009         }
4010         if (listop)
4011             ((LISTOP*)listop)->op_last->op_next =
4012                 (o == listop ? redo : LINKLIST(o));
4013     }
4014     else
4015         o = listop;
4016
4017     if (!loop) {
4018         NewOp(1101,loop,1,LOOP);
4019         loop->op_type = OP_ENTERLOOP;
4020         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4021         loop->op_private = 0;
4022         loop->op_next = (OP*)loop;
4023     }
4024
4025     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4026
4027     loop->op_redoop = redo;
4028     loop->op_lastop = o;
4029     o->op_private |= loopflags;
4030
4031     if (next)
4032         loop->op_nextop = next;
4033     else
4034         loop->op_nextop = o;
4035
4036     o->op_flags |= flags;
4037     o->op_private |= (flags >> 8);
4038     return o;
4039 }
4040
4041 OP *
4042 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4043 {
4044     LOOP *loop;
4045     OP *wop;
4046     int padoff = 0;
4047     I32 iterflags = 0;
4048
4049     if (sv) {
4050         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4051             sv->op_type = OP_RV2GV;
4052             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4053         }
4054         else if (sv->op_type == OP_PADSV) { /* private variable */
4055             padoff = sv->op_targ;
4056             sv->op_targ = 0;
4057             op_free(sv);
4058             sv = Nullop;
4059         }
4060         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4061             padoff = sv->op_targ;
4062             sv->op_targ = 0;
4063             iterflags |= OPf_SPECIAL;
4064             op_free(sv);
4065             sv = Nullop;
4066         }
4067         else
4068             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4069     }
4070     else {
4071 #ifdef USE_THREADS
4072         padoff = find_threadsv("_");
4073         iterflags |= OPf_SPECIAL;
4074 #else
4075         sv = newGVOP(OP_GV, 0, PL_defgv);
4076 #endif
4077     }
4078     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4079         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4080         iterflags |= OPf_STACKED;
4081     }
4082     else if (expr->op_type == OP_NULL &&
4083              (expr->op_flags & OPf_KIDS) &&
4084              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4085     {
4086         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4087          * set the STACKED flag to indicate that these values are to be
4088          * treated as min/max values by 'pp_iterinit'.
4089          */
4090         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4091         LOGOP* range = (LOGOP*) flip->op_first;
4092         OP* left  = range->op_first;
4093         OP* right = left->op_sibling;
4094         LISTOP* listop;
4095
4096         range->op_flags &= ~OPf_KIDS;
4097         range->op_first = Nullop;
4098
4099         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4100         listop->op_first->op_next = range->op_next;
4101         left->op_next = range->op_other;
4102         right->op_next = (OP*)listop;
4103         listop->op_next = listop->op_first;
4104
4105         op_free(expr);
4106         expr = (OP*)(listop);
4107         op_null(expr);
4108         iterflags |= OPf_STACKED;
4109     }
4110     else {
4111         expr = mod(force_list(expr), OP_GREPSTART);
4112     }
4113
4114
4115     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4116                                append_elem(OP_LIST, expr, scalar(sv))));
4117     assert(!loop->op_next);
4118 #ifdef PL_OP_SLAB_ALLOC
4119     {
4120         LOOP *tmp;
4121         NewOp(1234,tmp,1,LOOP);
4122         Copy(loop,tmp,1,LOOP);
4123         loop = tmp;
4124     }
4125 #else
4126     Renew(loop, 1, LOOP);
4127 #endif
4128     loop->op_targ = padoff;
4129     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4130     PL_copline = forline;
4131     return newSTATEOP(0, label, wop);
4132 }
4133
4134 OP*
4135 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4136 {
4137     OP *o;
4138     STRLEN n_a;
4139
4140     if (type != OP_GOTO || label->op_type == OP_CONST) {
4141         /* "last()" means "last" */
4142         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4143             o = newOP(type, OPf_SPECIAL);
4144         else {
4145             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4146                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4147                                         : ""));
4148         }
4149         op_free(label);
4150     }
4151     else {
4152         if (label->op_type == OP_ENTERSUB)
4153             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4154         o = newUNOP(type, OPf_STACKED, label);
4155     }
4156     PL_hints |= HINT_BLOCK_SCOPE;
4157     return o;
4158 }
4159
4160 void
4161 Perl_cv_undef(pTHX_ CV *cv)
4162 {
4163 #ifdef USE_THREADS
4164     if (CvMUTEXP(cv)) {
4165         MUTEX_DESTROY(CvMUTEXP(cv));
4166         Safefree(CvMUTEXP(cv));
4167         CvMUTEXP(cv) = 0;
4168     }
4169 #endif /* USE_THREADS */
4170
4171 #ifdef USE_ITHREADS
4172     if (CvFILE(cv) && !CvXSUB(cv)) {
4173         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4174         Safefree(CvFILE(cv));
4175     }
4176     CvFILE(cv) = 0;
4177 #endif
4178
4179     if (!CvXSUB(cv) && CvROOT(cv)) {
4180 #ifdef USE_THREADS
4181         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4182             Perl_croak(aTHX_ "Can't undef active subroutine");
4183 #else
4184         if (CvDEPTH(cv))
4185             Perl_croak(aTHX_ "Can't undef active subroutine");
4186 #endif /* USE_THREADS */
4187         ENTER;
4188
4189         SAVEVPTR(PL_curpad);
4190         PL_curpad = 0;
4191
4192         op_free(CvROOT(cv));
4193         CvROOT(cv) = Nullop;
4194         LEAVE;
4195     }
4196     SvPOK_off((SV*)cv);         /* forget prototype */
4197     CvGV(cv) = Nullgv;
4198     /* Since closure prototypes have the same lifetime as the containing
4199      * CV, they don't hold a refcount on the outside CV.  This avoids
4200      * the refcount loop between the outer CV (which keeps a refcount to
4201      * the closure prototype in the pad entry for pp_anoncode()) and the
4202      * closure prototype, and the ensuing memory leak.  This does not
4203      * apply to closures generated within eval"", since eval"" CVs are
4204      * ephemeral. --GSAR */
4205     if (!CvANON(cv) || CvCLONED(cv)
4206         || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4207             && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4208     {
4209         SvREFCNT_dec(CvOUTSIDE(cv));
4210     }
4211     CvOUTSIDE(cv) = Nullcv;
4212     if (CvCONST(cv)) {
4213         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4214         CvCONST_off(cv);
4215     }
4216     if (CvPADLIST(cv)) {
4217         /* may be during global destruction */
4218         if (SvREFCNT(CvPADLIST(cv))) {
4219             I32 i = AvFILLp(CvPADLIST(cv));
4220             while (i >= 0) {
4221                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4222                 SV* sv = svp ? *svp : Nullsv;
4223                 if (!sv)
4224                     continue;
4225                 if (sv == (SV*)PL_comppad_name)
4226                     PL_comppad_name = Nullav;
4227                 else if (sv == (SV*)PL_comppad) {
4228                     PL_comppad = Nullav;
4229                     PL_curpad = Null(SV**);
4230                 }
4231                 SvREFCNT_dec(sv);
4232             }
4233             SvREFCNT_dec((SV*)CvPADLIST(cv));
4234         }
4235         CvPADLIST(cv) = Nullav;
4236     }
4237     if (CvXSUB(cv)) {
4238         CvXSUB(cv) = 0;
4239     }
4240     CvFLAGS(cv) = 0;
4241 }
4242
4243 #ifdef DEBUG_CLOSURES
4244 STATIC void
4245 S_cv_dump(pTHX_ CV *cv)
4246 {
4247 #ifdef DEBUGGING
4248     CV *outside = CvOUTSIDE(cv);
4249     AV* padlist = CvPADLIST(cv);
4250     AV* pad_name;
4251     AV* pad;
4252     SV** pname;
4253     SV** ppad;
4254     I32 ix;
4255
4256     PerlIO_printf(Perl_debug_log,
4257                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4258                   PTR2UV(cv),
4259                   (CvANON(cv) ? "ANON"
4260                    : (cv == PL_main_cv) ? "MAIN"
4261                    : CvUNIQUE(cv) ? "UNIQUE"
4262                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4263                   PTR2UV(outside),
4264                   (!outside ? "null"
4265                    : CvANON(outside) ? "ANON"
4266                    : (outside == PL_main_cv) ? "MAIN"
4267                    : CvUNIQUE(outside) ? "UNIQUE"
4268                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4269
4270     if (!padlist)
4271         return;
4272
4273     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4274     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4275     pname = AvARRAY(pad_name);
4276     ppad = AvARRAY(pad);
4277
4278     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4279         if (SvPOK(pname[ix]))
4280             PerlIO_printf(Perl_debug_log,
4281                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4282                           (int)ix, PTR2UV(ppad[ix]),
4283                           SvFAKE(pname[ix]) ? "FAKE " : "",
4284                           SvPVX(pname[ix]),
4285                           (IV)I_32(SvNVX(pname[ix])),
4286                           SvIVX(pname[ix]));
4287     }
4288 #endif /* DEBUGGING */
4289 }
4290 #endif /* DEBUG_CLOSURES */
4291
4292 STATIC CV *
4293 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4294 {
4295     AV* av;
4296     I32 ix;
4297     AV* protopadlist = CvPADLIST(proto);
4298     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4299     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4300     SV** pname = AvARRAY(protopad_name);
4301     SV** ppad = AvARRAY(protopad);
4302     I32 fname = AvFILLp(protopad_name);
4303     I32 fpad = AvFILLp(protopad);
4304     AV* comppadlist;
4305     CV* cv;
4306
4307     assert(!CvUNIQUE(proto));
4308
4309     ENTER;
4310     SAVECOMPPAD();
4311     SAVESPTR(PL_comppad_name);
4312     SAVESPTR(PL_compcv);
4313
4314     cv = PL_compcv = (CV*)NEWSV(1104,0);
4315     sv_upgrade((SV *)cv, SvTYPE(proto));
4316     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4317     CvCLONED_on(cv);
4318
4319 #ifdef USE_THREADS
4320     New(666, CvMUTEXP(cv), 1, perl_mutex);
4321     MUTEX_INIT(CvMUTEXP(cv));
4322     CvOWNER(cv)         = 0;
4323 #endif /* USE_THREADS */
4324 #ifdef USE_ITHREADS
4325     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
4326                                         : savepv(CvFILE(proto));
4327 #else
4328     CvFILE(cv)          = CvFILE(proto);
4329 #endif
4330     CvGV(cv)            = CvGV(proto);
4331     CvSTASH(cv)         = CvSTASH(proto);
4332     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4333     CvSTART(cv)         = CvSTART(proto);
4334     if (outside)
4335         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4336
4337     if (SvPOK(proto))
4338         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4339
4340     PL_comppad_name = newAV();
4341     for (ix = fname; ix >= 0; ix--)
4342         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4343
4344     PL_comppad = newAV();
4345
4346     comppadlist = newAV();
4347     AvREAL_off(comppadlist);
4348     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4349     av_store(comppadlist, 1, (SV*)PL_comppad);
4350     CvPADLIST(cv) = comppadlist;
4351     av_fill(PL_comppad, AvFILLp(protopad));
4352     PL_curpad = AvARRAY(PL_comppad);
4353
4354     av = newAV();           /* will be @_ */
4355     av_extend(av, 0);
4356     av_store(PL_comppad, 0, (SV*)av);
4357     AvFLAGS(av) = AVf_REIFY;
4358
4359     for (ix = fpad; ix > 0; ix--) {
4360         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4361         if (namesv && namesv != &PL_sv_undef) {
4362             char *name = SvPVX(namesv);    /* XXX */
4363             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4364                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4365                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4366                 if (!off)
4367                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4368                 else if (off != ix)
4369                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4370             }
4371             else {                              /* our own lexical */
4372                 SV* sv;
4373                 if (*name == '&') {
4374                     /* anon code -- we'll come back for it */
4375                     sv = SvREFCNT_inc(ppad[ix]);
4376                 }
4377                 else if (*name == '@')
4378                     sv = (SV*)newAV();
4379                 else if (*name == '%')
4380                     sv = (SV*)newHV();
4381                 else
4382                     sv = NEWSV(0,0);
4383                 if (!SvPADBUSY(sv))
4384                     SvPADMY_on(sv);
4385                 PL_curpad[ix] = sv;
4386             }
4387         }
4388         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4389             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4390         }
4391         else {
4392             SV* sv = NEWSV(0,0);
4393             SvPADTMP_on(sv);
4394             PL_curpad[ix] = sv;
4395         }
4396     }
4397
4398     /* Now that vars are all in place, clone nested closures. */
4399
4400     for (ix = fpad; ix > 0; ix--) {
4401         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4402         if (namesv
4403             && namesv != &PL_sv_undef
4404             && !(SvFLAGS(namesv) & SVf_FAKE)
4405             && *SvPVX(namesv) == '&'
4406             && CvCLONE(ppad[ix]))
4407         {
4408             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4409             SvREFCNT_dec(ppad[ix]);
4410             CvCLONE_on(kid);
4411             SvPADMY_on(kid);
4412             PL_curpad[ix] = (SV*)kid;
4413         }
4414     }
4415
4416 #ifdef DEBUG_CLOSURES
4417     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4418     cv_dump(outside);
4419     PerlIO_printf(Perl_debug_log, "  from:\n");
4420     cv_dump(proto);
4421     PerlIO_printf(Perl_debug_log, "   to:\n");
4422     cv_dump(cv);
4423 #endif
4424
4425     LEAVE;
4426
4427     if (CvCONST(cv)) {
4428         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4429         assert(const_sv);
4430         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4431         SvREFCNT_dec(cv);
4432         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4433     }
4434
4435     return cv;
4436 }
4437
4438 CV *
4439 Perl_cv_clone(pTHX_ CV *proto)
4440 {
4441     CV *cv;
4442     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4443     cv = cv_clone2(proto, CvOUTSIDE(proto));
4444     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4445     return cv;
4446 }
4447
4448 void
4449 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4450 {
4451     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4452         SV* msg = sv_newmortal();
4453         SV* name = Nullsv;
4454
4455         if (gv)
4456             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4457         sv_setpv(msg, "Prototype mismatch:");
4458         if (name)
4459             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4460         if (SvPOK(cv))
4461             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4462         sv_catpv(msg, " vs ");
4463         if (p)
4464             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4465         else
4466             sv_catpv(msg, "none");
4467         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4468     }
4469 }
4470
4471 static void const_sv_xsub(pTHXo_ CV* cv);
4472
4473 /*
4474 =for apidoc cv_const_sv
4475
4476 If C<cv> is a constant sub eligible for inlining. returns the constant
4477 value returned by the sub.  Otherwise, returns NULL.
4478
4479 Constant subs can be created with C<newCONSTSUB> or as described in
4480 L<perlsub/"Constant Functions">.
4481
4482 =cut
4483 */
4484 SV *
4485 Perl_cv_const_sv(pTHX_ CV *cv)
4486 {
4487     if (!cv || !CvCONST(cv))
4488         return Nullsv;
4489     return (SV*)CvXSUBANY(cv).any_ptr;
4490 }
4491
4492 SV *
4493 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4494 {
4495     SV *sv = Nullsv;
4496
4497     if (!o)
4498         return Nullsv;
4499
4500     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4501         o = cLISTOPo->op_first->op_sibling;
4502
4503     for (; o; o = o->op_next) {
4504         OPCODE type = o->op_type;
4505
4506         if (sv && o->op_next == o)
4507             return sv;
4508         if (o->op_next != o) {
4509             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4510                 continue;
4511             if (type == OP_DBSTATE)
4512                 continue;
4513         }
4514         if (type == OP_LEAVESUB || type == OP_RETURN)
4515             break;
4516         if (sv)
4517             return Nullsv;
4518         if (type == OP_CONST && cSVOPo->op_sv)
4519             sv = cSVOPo->op_sv;
4520         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4521             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4522             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4523             if (!sv)
4524                 return Nullsv;
4525             if (CvCONST(cv)) {
4526                 /* We get here only from cv_clone2() while creating a closure.
4527                    Copy the const value here instead of in cv_clone2 so that
4528                    SvREADONLY_on doesn't lead to problems when leaving
4529                    scope.
4530                 */
4531                 sv = newSVsv(sv);
4532             }
4533             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4534                 return Nullsv;
4535         }
4536         else
4537             return Nullsv;
4538     }
4539     if (sv)
4540         SvREADONLY_on(sv);
4541     return sv;
4542 }
4543
4544 void
4545 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4546 {
4547     if (o)
4548         SAVEFREEOP(o);
4549     if (proto)
4550         SAVEFREEOP(proto);
4551     if (attrs)
4552         SAVEFREEOP(attrs);
4553     if (block)
4554         SAVEFREEOP(block);
4555     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4556 }
4557
4558 CV *
4559 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4560 {
4561     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4562 }
4563
4564 CV *
4565 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4566 {
4567     STRLEN n_a;
4568     char *name;
4569     char *aname;
4570     GV *gv;
4571     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4572     register CV *cv=0;
4573     I32 ix;
4574     SV *const_sv;
4575
4576     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4577     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4578         SV *sv = sv_newmortal();
4579         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4580                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4581         aname = SvPVX(sv);
4582     }
4583     else
4584         aname = Nullch;
4585     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4586                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4587                     SVt_PVCV);
4588
4589     if (o)
4590         SAVEFREEOP(o);
4591     if (proto)
4592         SAVEFREEOP(proto);
4593     if (attrs)
4594         SAVEFREEOP(attrs);
4595
4596     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4597                                            maximum a prototype before. */
4598         if (SvTYPE(gv) > SVt_NULL) {
4599             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4600                 && ckWARN_d(WARN_PROTOTYPE))
4601             {
4602                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4603             }
4604             cv_ckproto((CV*)gv, NULL, ps);
4605         }
4606         if (ps)
4607             sv_setpv((SV*)gv, ps);
4608         else
4609             sv_setiv((SV*)gv, -1);
4610         SvREFCNT_dec(PL_compcv);
4611         cv = PL_compcv = NULL;
4612         PL_sub_generation++;
4613         goto done;
4614     }
4615
4616     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4617
4618 #ifdef GV_UNIQUE_CHECK
4619     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4620         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4621     }
4622 #endif
4623
4624     if (!block || !ps || *ps || attrs)
4625         const_sv = Nullsv;
4626     else
4627         const_sv = op_const_sv(block, Nullcv);
4628
4629     if (cv) {
4630         bool exists = CvROOT(cv) || CvXSUB(cv);
4631
4632 #ifdef GV_UNIQUE_CHECK
4633         if (exists && GvUNIQUE(gv)) {
4634             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4635         }
4636 #endif
4637
4638         /* if the subroutine doesn't exist and wasn't pre-declared
4639          * with a prototype, assume it will be AUTOLOADed,
4640          * skipping the prototype check
4641          */
4642         if (exists || SvPOK(cv))
4643             cv_ckproto(cv, gv, ps);
4644         /* already defined (or promised)? */
4645         if (exists || GvASSUMECV(gv)) {
4646             if (!block && !attrs) {
4647                 /* just a "sub foo;" when &foo is already defined */
4648                 SAVEFREESV(PL_compcv);
4649                 goto done;
4650             }
4651             /* ahem, death to those who redefine active sort subs */
4652             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4653                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4654             if (block) {
4655                 if (ckWARN(WARN_REDEFINE)
4656                     || (CvCONST(cv)
4657                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4658                 {
4659                     line_t oldline = CopLINE(PL_curcop);
4660                     CopLINE_set(PL_curcop, PL_copline);
4661                     Perl_warner(aTHX_ WARN_REDEFINE,
4662                         CvCONST(cv) ? "Constant subroutine %s redefined"
4663                                     : "Subroutine %s redefined", name);
4664                     CopLINE_set(PL_curcop, oldline);
4665                 }
4666                 SvREFCNT_dec(cv);
4667                 cv = Nullcv;
4668             }
4669         }
4670     }
4671     if (const_sv) {
4672         SvREFCNT_inc(const_sv);
4673         if (cv) {
4674             assert(!CvROOT(cv) && !CvCONST(cv));
4675             sv_setpv((SV*)cv, "");  /* prototype is "" */
4676             CvXSUBANY(cv).any_ptr = const_sv;
4677             CvXSUB(cv) = const_sv_xsub;
4678             CvCONST_on(cv);
4679         }
4680         else {
4681             GvCV(gv) = Nullcv;
4682             cv = newCONSTSUB(NULL, name, const_sv);
4683         }
4684         op_free(block);
4685         SvREFCNT_dec(PL_compcv);
4686         PL_compcv = NULL;
4687         PL_sub_generation++;
4688         goto done;
4689     }
4690     if (attrs) {
4691         HV *stash;
4692         SV *rcv;
4693
4694         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4695          * before we clobber PL_compcv.
4696          */
4697         if (cv && !block) {
4698             rcv = (SV*)cv;
4699             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4700                 stash = GvSTASH(CvGV(cv));
4701             else if (CvSTASH(cv))
4702                 stash = CvSTASH(cv);
4703             else
4704                 stash = PL_curstash;
4705         }
4706         else {
4707             /* possibly about to re-define existing subr -- ignore old cv */
4708             rcv = (SV*)PL_compcv;
4709             if (name && GvSTASH(gv))
4710                 stash = GvSTASH(gv);
4711             else
4712                 stash = PL_curstash;
4713         }
4714         apply_attrs(stash, rcv, attrs);
4715     }
4716     if (cv) {                           /* must reuse cv if autoloaded */
4717         if (!block) {
4718             /* got here with just attrs -- work done, so bug out */
4719             SAVEFREESV(PL_compcv);
4720             goto done;
4721         }
4722         cv_undef(cv);
4723         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4724         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4725         CvOUTSIDE(PL_compcv) = 0;
4726         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4727         CvPADLIST(PL_compcv) = 0;
4728         /* inner references to PL_compcv must be fixed up ... */
4729         {
4730             AV *padlist = CvPADLIST(cv);
4731             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4732             AV *comppad = (AV*)AvARRAY(padlist)[1];
4733             SV **namepad = AvARRAY(comppad_name);
4734             SV **curpad = AvARRAY(comppad);
4735             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4736                 SV *namesv = namepad[ix];
4737                 if (namesv && namesv != &PL_sv_undef
4738                     && *SvPVX(namesv) == '&')
4739                 {
4740                     CV *innercv = (CV*)curpad[ix];
4741                     if (CvOUTSIDE(innercv) == PL_compcv) {
4742                         CvOUTSIDE(innercv) = cv;
4743                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4744                             (void)SvREFCNT_inc(cv);
4745                             SvREFCNT_dec(PL_compcv);
4746                         }
4747                     }
4748                 }
4749             }
4750         }
4751         /* ... before we throw it away */
4752         SvREFCNT_dec(PL_compcv);
4753         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4754           ++PL_sub_generation;
4755     }
4756     else {
4757         cv = PL_compcv;
4758         if (name) {
4759             GvCV(gv) = cv;
4760             GvCVGEN(gv) = 0;
4761             PL_sub_generation++;
4762         }
4763     }
4764     CvGV(cv) = gv;
4765     CvFILE_set_from_cop(cv, PL_curcop);
4766     CvSTASH(cv) = PL_curstash;
4767 #ifdef USE_THREADS
4768     CvOWNER(cv) = 0;
4769     if (!CvMUTEXP(cv)) {
4770         New(666, CvMUTEXP(cv), 1, perl_mutex);
4771         MUTEX_INIT(CvMUTEXP(cv));
4772     }
4773 #endif /* USE_THREADS */
4774
4775     if (ps)
4776         sv_setpv((SV*)cv, ps);
4777
4778     if (PL_error_count) {
4779         op_free(block);
4780         block = Nullop;
4781         if (name) {
4782             char *s = strrchr(name, ':');
4783             s = s ? s+1 : name;
4784             if (strEQ(s, "BEGIN")) {
4785                 char *not_safe =
4786                     "BEGIN not safe after errors--compilation aborted";
4787                 if (PL_in_eval & EVAL_KEEPERR)
4788                     Perl_croak(aTHX_ not_safe);
4789                 else {
4790                     /* force display of errors found but not reported */
4791                     sv_catpv(ERRSV, not_safe);
4792                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4793                 }
4794             }
4795         }
4796     }
4797     if (!block)
4798         goto done;
4799
4800     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4801         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4802
4803     if (CvLVALUE(cv)) {
4804         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4805                              mod(scalarseq(block), OP_LEAVESUBLV));
4806     }
4807     else {
4808         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4809     }
4810     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4811     OpREFCNT_set(CvROOT(cv), 1);
4812     CvSTART(cv) = LINKLIST(CvROOT(cv));
4813     CvROOT(cv)->op_next = 0;
4814     peep(CvSTART(cv));
4815
4816     /* now that optimizer has done its work, adjust pad values */
4817     if (CvCLONE(cv)) {
4818         SV **namep = AvARRAY(PL_comppad_name);
4819         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4820             SV *namesv;
4821
4822             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4823                 continue;
4824             /*
4825              * The only things that a clonable function needs in its
4826              * pad are references to outer lexicals and anonymous subs.
4827              * The rest are created anew during cloning.
4828              */
4829             if (!((namesv = namep[ix]) != Nullsv &&
4830                   namesv != &PL_sv_undef &&
4831                   (SvFAKE(namesv) ||
4832                    *SvPVX(namesv) == '&')))
4833             {
4834                 SvREFCNT_dec(PL_curpad[ix]);
4835                 PL_curpad[ix] = Nullsv;
4836             }
4837         }
4838         assert(!CvCONST(cv));
4839         if (ps && !*ps && op_const_sv(block, cv))
4840             CvCONST_on(cv);
4841     }
4842     else {
4843         AV *av = newAV();                       /* Will be @_ */
4844         av_extend(av, 0);
4845         av_store(PL_comppad, 0, (SV*)av);
4846         AvFLAGS(av) = AVf_REIFY;
4847
4848         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4849             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4850                 continue;
4851             if (!SvPADMY(PL_curpad[ix]))
4852                 SvPADTMP_on(PL_curpad[ix]);
4853         }
4854     }
4855
4856     /* If a potential closure prototype, don't keep a refcount on
4857      * outer CV, unless the latter happens to be a passing eval"".
4858      * This is okay as the lifetime of the prototype is tied to the
4859      * lifetime of the outer CV.  Avoids memory leak due to reference
4860      * loop. --GSAR */
4861     if (!name && CvOUTSIDE(cv)
4862         && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4863              && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4864     {
4865         SvREFCNT_dec(CvOUTSIDE(cv));
4866     }
4867
4868     if (name || aname) {
4869         char *s;
4870         char *tname = (name ? name : aname);
4871
4872         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4873             SV *sv = NEWSV(0,0);
4874             SV *tmpstr = sv_newmortal();
4875             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4876             CV *pcv;
4877             HV *hv;
4878
4879             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4880                            CopFILE(PL_curcop),
4881                            (long)PL_subline, (long)CopLINE(PL_curcop));
4882             gv_efullname3(tmpstr, gv, Nullch);
4883             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4884             hv = GvHVn(db_postponed);
4885             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4886                 && (pcv = GvCV(db_postponed)))
4887             {
4888                 dSP;
4889                 PUSHMARK(SP);
4890                 XPUSHs(tmpstr);
4891                 PUTBACK;
4892                 call_sv((SV*)pcv, G_DISCARD);
4893             }
4894         }
4895
4896         if ((s = strrchr(tname,':')))
4897             s++;
4898         else
4899             s = tname;
4900
4901         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4902             goto done;
4903
4904         if (strEQ(s, "BEGIN")) {
4905             I32 oldscope = PL_scopestack_ix;
4906             ENTER;
4907             SAVECOPFILE(&PL_compiling);
4908             SAVECOPLINE(&PL_compiling);
4909             save_svref(&PL_rs);
4910             sv_setsv(PL_rs, PL_nrs);
4911
4912             if (!PL_beginav)
4913                 PL_beginav = newAV();
4914             DEBUG_x( dump_sub(gv) );
4915             av_push(PL_beginav, (SV*)cv);
4916             GvCV(gv) = 0;               /* cv has been hijacked */
4917             call_list(oldscope, PL_beginav);
4918
4919             PL_curcop = &PL_compiling;
4920             PL_compiling.op_private = PL_hints;
4921             LEAVE;
4922         }
4923         else if (strEQ(s, "END") && !PL_error_count) {
4924             if (!PL_endav)
4925                 PL_endav = newAV();
4926             DEBUG_x( dump_sub(gv) );
4927             av_unshift(PL_endav, 1);
4928             av_store(PL_endav, 0, (SV*)cv);
4929             GvCV(gv) = 0;               /* cv has been hijacked */
4930         }
4931         else if (strEQ(s, "CHECK") && !PL_error_count) {
4932             if (!PL_checkav)
4933                 PL_checkav = newAV();
4934             DEBUG_x( dump_sub(gv) );
4935             if (PL_main_start && ckWARN(WARN_VOID))
4936                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4937             av_unshift(PL_checkav, 1);
4938             av_store(PL_checkav, 0, (SV*)cv);
4939             GvCV(gv) = 0;               /* cv has been hijacked */
4940         }
4941         else if (strEQ(s, "INIT") && !PL_error_count) {
4942             if (!PL_initav)
4943                 PL_initav = newAV();
4944             DEBUG_x( dump_sub(gv) );
4945             if (PL_main_start && ckWARN(WARN_VOID))
4946                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4947             av_push(PL_initav, (SV*)cv);
4948             GvCV(gv) = 0;               /* cv has been hijacked */
4949         }
4950     }
4951
4952   done:
4953     PL_copline = NOLINE;
4954     LEAVE_SCOPE(floor);
4955     return cv;
4956 }
4957
4958 /* XXX unsafe for threads if eval_owner isn't held */
4959 /*
4960 =for apidoc newCONSTSUB
4961
4962 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4963 eligible for inlining at compile-time.
4964
4965 =cut
4966 */
4967
4968 CV *
4969 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4970 {
4971     CV* cv;
4972
4973     ENTER;
4974
4975     SAVECOPLINE(PL_curcop);
4976     CopLINE_set(PL_curcop, PL_copline);
4977
4978     SAVEHINTS();
4979     PL_hints &= ~HINT_BLOCK_SCOPE;
4980
4981     if (stash) {
4982         SAVESPTR(PL_curstash);
4983         SAVECOPSTASH(PL_curcop);
4984         PL_curstash = stash;
4985 #ifdef USE_ITHREADS
4986         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4987 #else
4988         CopSTASH(PL_curcop) = stash;
4989 #endif
4990     }
4991
4992     cv = newXS(name, const_sv_xsub, __FILE__);
4993     CvXSUBANY(cv).any_ptr = sv;
4994     CvCONST_on(cv);
4995     sv_setpv((SV*)cv, "");  /* prototype is "" */
4996
4997     LEAVE;
4998
4999     return cv;
5000 }
5001
5002 /*
5003 =for apidoc U||newXS
5004
5005 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5006
5007 =cut
5008 */
5009
5010 CV *
5011 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5012 {
5013     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5014     register CV *cv;
5015
5016     if ((cv = (name ? GvCV(gv) : Nullcv))) {
5017         if (GvCVGEN(gv)) {
5018             /* just a cached method */
5019             SvREFCNT_dec(cv);
5020             cv = 0;
5021         }
5022         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5023             /* already defined (or promised) */
5024             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5025                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5026                 line_t oldline = CopLINE(PL_curcop);
5027                 if (PL_copline != NOLINE)
5028                     CopLINE_set(PL_curcop, PL_copline);
5029                 Perl_warner(aTHX_ WARN_REDEFINE,
5030                             CvCONST(cv) ? "Constant subroutine %s redefined"
5031                                         : "Subroutine %s redefined"
5032                             ,name);
5033                 CopLINE_set(PL_curcop, oldline);
5034             }
5035             SvREFCNT_dec(cv);
5036             cv = 0;
5037         }
5038     }
5039
5040     if (cv)                             /* must reuse cv if autoloaded */
5041         cv_undef(cv);
5042     else {
5043         cv = (CV*)NEWSV(1105,0);
5044         sv_upgrade((SV *)cv, SVt_PVCV);
5045         if (name) {
5046             GvCV(gv) = cv;
5047             GvCVGEN(gv) = 0;
5048             PL_sub_generation++;
5049         }
5050     }
5051     CvGV(cv) = gv;
5052 #ifdef USE_THREADS
5053     New(666, CvMUTEXP(cv), 1, perl_mutex);
5054     MUTEX_INIT(CvMUTEXP(cv));
5055     CvOWNER(cv) = 0;
5056 #endif /* USE_THREADS */
5057     (void)gv_fetchfile(filename);
5058     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5059                                    an external constant string */
5060     CvXSUB(cv) = subaddr;
5061
5062     if (name) {
5063         char *s = strrchr(name,':');
5064         if (s)
5065             s++;
5066         else
5067             s = name;
5068
5069         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5070             goto done;
5071
5072         if (strEQ(s, "BEGIN")) {
5073             if (!PL_beginav)
5074                 PL_beginav = newAV();
5075             av_push(PL_beginav, (SV*)cv);
5076             GvCV(gv) = 0;               /* cv has been hijacked */
5077         }
5078         else if (strEQ(s, "END")) {
5079             if (!PL_endav)
5080                 PL_endav = newAV();
5081             av_unshift(PL_endav, 1);
5082             av_store(PL_endav, 0, (SV*)cv);
5083             GvCV(gv) = 0;               /* cv has been hijacked */
5084         }
5085         else if (strEQ(s, "CHECK")) {
5086             if (!PL_checkav)
5087                 PL_checkav = newAV();
5088             if (PL_main_start && ckWARN(WARN_VOID))
5089                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5090             av_unshift(PL_checkav, 1);
5091             av_store(PL_checkav, 0, (SV*)cv);
5092             GvCV(gv) = 0;               /* cv has been hijacked */
5093         }
5094         else if (strEQ(s, "INIT")) {
5095             if (!PL_initav)
5096                 PL_initav = newAV();
5097             if (PL_main_start && ckWARN(WARN_VOID))
5098                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5099             av_push(PL_initav, (SV*)cv);
5100             GvCV(gv) = 0;               /* cv has been hijacked */
5101         }
5102     }
5103     else
5104         CvANON_on(cv);
5105
5106 done:
5107     return cv;
5108 }
5109
5110 void
5111 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5112 {
5113     register CV *cv;
5114     char *name;
5115     GV *gv;
5116     I32 ix;
5117     STRLEN n_a;
5118
5119     if (o)
5120         name = SvPVx(cSVOPo->op_sv, n_a);
5121     else
5122         name = "STDOUT";
5123     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5124 #ifdef GV_UNIQUE_CHECK
5125     if (GvUNIQUE(gv)) {
5126         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5127     }
5128 #endif
5129     GvMULTI_on(gv);
5130     if ((cv = GvFORM(gv))) {
5131         if (ckWARN(WARN_REDEFINE)) {
5132             line_t oldline = CopLINE(PL_curcop);
5133
5134             CopLINE_set(PL_curcop, PL_copline);
5135             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5136             CopLINE_set(PL_curcop, oldline);
5137         }
5138         SvREFCNT_dec(cv);
5139     }
5140     cv = PL_compcv;
5141     GvFORM(gv) = cv;
5142     CvGV(cv) = gv;
5143     CvFILE_set_from_cop(cv, PL_curcop);
5144
5145     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5146         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5147             SvPADTMP_on(PL_curpad[ix]);
5148     }
5149
5150     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5151     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5152     OpREFCNT_set(CvROOT(cv), 1);
5153     CvSTART(cv) = LINKLIST(CvROOT(cv));
5154     CvROOT(cv)->op_next = 0;
5155     peep(CvSTART(cv));
5156     op_free(o);
5157     PL_copline = NOLINE;
5158     LEAVE_SCOPE(floor);
5159 }
5160
5161 OP *
5162 Perl_newANONLIST(pTHX_ OP *o)
5163 {
5164     return newUNOP(OP_REFGEN, 0,
5165         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5166 }
5167
5168 OP *
5169 Perl_newANONHASH(pTHX_ OP *o)
5170 {
5171     return newUNOP(OP_REFGEN, 0,
5172         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5173 }
5174
5175 OP *
5176 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5177 {
5178     return newANONATTRSUB(floor, proto, Nullop, block);
5179 }
5180
5181 OP *
5182 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5183 {
5184     return newUNOP(OP_REFGEN, 0,
5185         newSVOP(OP_ANONCODE, 0,
5186                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5187 }
5188
5189 OP *
5190 Perl_oopsAV(pTHX_ OP *o)
5191 {
5192     switch (o->op_type) {
5193     case OP_PADSV:
5194         o->op_type = OP_PADAV;
5195         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5196         return ref(o, OP_RV2AV);
5197
5198     case OP_RV2SV:
5199         o->op_type = OP_RV2AV;
5200         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5201         ref(o, OP_RV2AV);
5202         break;
5203
5204     default:
5205         if (ckWARN_d(WARN_INTERNAL))
5206             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5207         break;
5208     }
5209     return o;
5210 }
5211
5212 OP *
5213 Perl_oopsHV(pTHX_ OP *o)
5214 {
5215     switch (o->op_type) {
5216     case OP_PADSV:
5217     case OP_PADAV:
5218         o->op_type = OP_PADHV;
5219         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5220         return ref(o, OP_RV2HV);
5221
5222     case OP_RV2SV:
5223     case OP_RV2AV:
5224         o->op_type = OP_RV2HV;
5225         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5226         ref(o, OP_RV2HV);
5227         break;
5228
5229     default:
5230         if (ckWARN_d(WARN_INTERNAL))
5231             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5232         break;
5233     }
5234     return o;
5235 }
5236
5237 OP *
5238 Perl_newAVREF(pTHX_ OP *o)
5239 {
5240     if (o->op_type == OP_PADANY) {
5241         o->op_type = OP_PADAV;
5242         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5243         return o;
5244     }
5245     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5246                 && ckWARN(WARN_DEPRECATED)) {
5247         Perl_warner(aTHX_ WARN_DEPRECATED,
5248                 "Using an array as a reference is deprecated");
5249     }
5250     return newUNOP(OP_RV2AV, 0, scalar(o));
5251 }
5252
5253 OP *
5254 Perl_newGVREF(pTHX_ I32 type, OP *o)
5255 {
5256     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5257         return newUNOP(OP_NULL, 0, o);
5258     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5259 }
5260
5261 OP *
5262 Perl_newHVREF(pTHX_ OP *o)
5263 {
5264     if (o->op_type == OP_PADANY) {
5265         o->op_type = OP_PADHV;
5266         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5267         return o;
5268     }
5269     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5270                 && ckWARN(WARN_DEPRECATED)) {
5271         Perl_warner(aTHX_ WARN_DEPRECATED,
5272                 "Using a hash as a reference is deprecated");
5273     }
5274     return newUNOP(OP_RV2HV, 0, scalar(o));
5275 }
5276
5277 OP *
5278 Perl_oopsCV(pTHX_ OP *o)
5279 {
5280     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5281     /* STUB */
5282     return o;
5283 }
5284
5285 OP *
5286 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5287 {
5288     return newUNOP(OP_RV2CV, flags, scalar(o));
5289 }
5290
5291 OP *
5292 Perl_newSVREF(pTHX_ OP *o)
5293 {
5294     if (o->op_type == OP_PADANY) {
5295         o->op_type = OP_PADSV;
5296         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5297         return o;
5298     }
5299     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5300         o->op_flags |= OPpDONE_SVREF;
5301         return o;
5302     }
5303     return newUNOP(OP_RV2SV, 0, scalar(o));
5304 }
5305
5306 /* Check routines. */
5307
5308 OP *
5309 Perl_ck_anoncode(pTHX_ OP *o)
5310 {
5311     PADOFFSET ix;
5312     SV* name;
5313
5314     name = NEWSV(1106,0);
5315     sv_upgrade(name, SVt_PVNV);
5316     sv_setpvn(name, "&", 1);
5317     SvIVX(name) = -1;
5318     SvNVX(name) = 1;
5319     ix = pad_alloc(o->op_type, SVs_PADMY);
5320     av_store(PL_comppad_name, ix, name);
5321     av_store(PL_comppad, ix, cSVOPo->op_sv);
5322     SvPADMY_on(cSVOPo->op_sv);
5323     cSVOPo->op_sv = Nullsv;
5324     cSVOPo->op_targ = ix;
5325     return o;
5326 }
5327
5328 OP *
5329 Perl_ck_bitop(pTHX_ OP *o)
5330 {
5331     o->op_private = PL_hints;
5332     return o;
5333 }
5334
5335 OP *
5336 Perl_ck_concat(pTHX_ OP *o)
5337 {
5338     if (cUNOPo->op_first->op_type == OP_CONCAT)
5339         o->op_flags |= OPf_STACKED;
5340     return o;
5341 }
5342
5343 OP *
5344 Perl_ck_spair(pTHX_ OP *o)
5345 {
5346     if (o->op_flags & OPf_KIDS) {
5347         OP* newop;
5348         OP* kid;
5349         OPCODE type = o->op_type;
5350         o = modkids(ck_fun(o), type);
5351         kid = cUNOPo->op_first;
5352         newop = kUNOP->op_first->op_sibling;
5353         if (newop &&
5354             (newop->op_sibling ||
5355              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5356              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5357              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5358
5359             return o;
5360         }
5361         op_free(kUNOP->op_first);
5362         kUNOP->op_first = newop;
5363     }
5364     o->op_ppaddr = PL_ppaddr[++o->op_type];
5365     return ck_fun(o);
5366 }
5367
5368 OP *
5369 Perl_ck_delete(pTHX_ OP *o)
5370 {
5371     o = ck_fun(o);
5372     o->op_private = 0;
5373     if (o->op_flags & OPf_KIDS) {
5374         OP *kid = cUNOPo->op_first;
5375         switch (kid->op_type) {
5376         case OP_ASLICE:
5377             o->op_flags |= OPf_SPECIAL;
5378             /* FALL THROUGH */
5379         case OP_HSLICE:
5380             o->op_private |= OPpSLICE;
5381             break;
5382         case OP_AELEM:
5383             o->op_flags |= OPf_SPECIAL;
5384             /* FALL THROUGH */
5385         case OP_HELEM:
5386             break;
5387         default:
5388             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5389                   PL_op_desc[o->op_type]);
5390         }
5391         op_null(kid);
5392     }
5393     return o;
5394 }
5395
5396 OP *
5397 Perl_ck_eof(pTHX_ OP *o)
5398 {
5399     I32 type = o->op_type;
5400
5401     if (o->op_flags & OPf_KIDS) {
5402         if (cLISTOPo->op_first->op_type == OP_STUB) {
5403             op_free(o);
5404             o = newUNOP(type, OPf_SPECIAL,
5405                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5406         }
5407         return ck_fun(o);
5408     }
5409     return o;
5410 }
5411
5412 OP *
5413 Perl_ck_eval(pTHX_ OP *o)
5414 {
5415     PL_hints |= HINT_BLOCK_SCOPE;
5416     if (o->op_flags & OPf_KIDS) {
5417         SVOP *kid = (SVOP*)cUNOPo->op_first;
5418
5419         if (!kid) {
5420             o->op_flags &= ~OPf_KIDS;
5421             op_null(o);
5422         }
5423         else if (kid->op_type == OP_LINESEQ) {
5424             LOGOP *enter;
5425
5426             kid->op_next = o->op_next;
5427             cUNOPo->op_first = 0;
5428             op_free(o);
5429
5430             NewOp(1101, enter, 1, LOGOP);
5431             enter->op_type = OP_ENTERTRY;
5432             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5433             enter->op_private = 0;
5434
5435             /* establish postfix order */
5436             enter->op_next = (OP*)enter;
5437
5438             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5439             o->op_type = OP_LEAVETRY;
5440             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5441             enter->op_other = o;
5442             return o;
5443         }
5444         else
5445             scalar((OP*)kid);
5446     }
5447     else {
5448         op_free(o);
5449         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5450     }
5451     o->op_targ = (PADOFFSET)PL_hints;
5452     return o;
5453 }
5454
5455 OP *
5456 Perl_ck_exit(pTHX_ OP *o)
5457 {
5458 #ifdef VMS
5459     HV *table = GvHV(PL_hintgv);
5460     if (table) {
5461        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5462        if (svp && *svp && SvTRUE(*svp))
5463            o->op_private |= OPpEXIT_VMSISH;
5464     }
5465 #endif
5466     return ck_fun(o);
5467 }
5468
5469 OP *
5470 Perl_ck_exec(pTHX_ OP *o)
5471 {
5472     OP *kid;
5473     if (o->op_flags & OPf_STACKED) {
5474         o = ck_fun(o);
5475         kid = cUNOPo->op_first->op_sibling;
5476         if (kid->op_type == OP_RV2GV)
5477             op_null(kid);
5478     }
5479     else
5480         o = listkids(o);
5481     return o;
5482 }
5483
5484 OP *
5485 Perl_ck_exists(pTHX_ OP *o)
5486 {
5487     o = ck_fun(o);
5488     if (o->op_flags & OPf_KIDS) {
5489         OP *kid = cUNOPo->op_first;
5490         if (kid->op_type == OP_ENTERSUB) {
5491             (void) ref(kid, o->op_type);
5492             if (kid->op_type != OP_RV2CV && !PL_error_count)
5493                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5494                            PL_op_desc[o->op_type]);
5495             o->op_private |= OPpEXISTS_SUB;
5496         }
5497         else if (kid->op_type == OP_AELEM)
5498             o->op_flags |= OPf_SPECIAL;
5499         else if (kid->op_type != OP_HELEM)
5500             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5501                        PL_op_desc[o->op_type]);
5502         op_null(kid);
5503     }
5504     return o;
5505 }
5506
5507 #if 0
5508 OP *
5509 Perl_ck_gvconst(pTHX_ register OP *o)
5510 {
5511     o = fold_constants(o);
5512     if (o->op_type == OP_CONST)
5513         o->op_type = OP_GV;
5514     return o;
5515 }
5516 #endif
5517
5518 OP *
5519 Perl_ck_rvconst(pTHX_ register OP *o)
5520 {
5521     SVOP *kid = (SVOP*)cUNOPo->op_first;
5522
5523     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5524     if (kid->op_type == OP_CONST) {
5525         char *name;
5526         int iscv;
5527         GV *gv;
5528         SV *kidsv = kid->op_sv;
5529         STRLEN n_a;
5530
5531         /* Is it a constant from cv_const_sv()? */
5532         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5533             SV *rsv = SvRV(kidsv);
5534             int svtype = SvTYPE(rsv);
5535             char *badtype = Nullch;
5536
5537             switch (o->op_type) {
5538             case OP_RV2SV:
5539                 if (svtype > SVt_PVMG)
5540                     badtype = "a SCALAR";
5541                 break;
5542             case OP_RV2AV:
5543                 if (svtype != SVt_PVAV)
5544                     badtype = "an ARRAY";
5545                 break;
5546             case OP_RV2HV:
5547                 if (svtype != SVt_PVHV) {
5548                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5549                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5550                         if (ksv && SvROK(*ksv)
5551                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5552                         {
5553                                 break;
5554                         }
5555                     }
5556                     badtype = "a HASH";
5557                 }
5558                 break;
5559             case OP_RV2CV:
5560                 if (svtype != SVt_PVCV)
5561                     badtype = "a CODE";
5562                 break;
5563             }
5564             if (badtype)
5565                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5566             return o;
5567         }
5568         name = SvPV(kidsv, n_a);
5569         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5570             char *badthing = Nullch;
5571             switch (o->op_type) {
5572             case OP_RV2SV:
5573                 badthing = "a SCALAR";
5574                 break;
5575             case OP_RV2AV:
5576                 badthing = "an ARRAY";
5577                 break;
5578             case OP_RV2HV:
5579                 badthing = "a HASH";
5580                 break;
5581             }
5582             if (badthing)
5583                 Perl_croak(aTHX_
5584           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5585                       name, badthing);
5586         }
5587         /*
5588          * This is a little tricky.  We only want to add the symbol if we
5589          * didn't add it in the lexer.  Otherwise we get duplicate strict
5590          * warnings.  But if we didn't add it in the lexer, we must at
5591          * least pretend like we wanted to add it even if it existed before,
5592          * or we get possible typo warnings.  OPpCONST_ENTERED says
5593          * whether the lexer already added THIS instance of this symbol.
5594          */
5595         iscv = (o->op_type == OP_RV2CV) * 2;
5596         do {
5597             gv = gv_fetchpv(name,
5598                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5599                 iscv
5600                     ? SVt_PVCV
5601                     : o->op_type == OP_RV2SV
5602                         ? SVt_PV
5603                         : o->op_type == OP_RV2AV
5604                             ? SVt_PVAV
5605                             : o->op_type == OP_RV2HV
5606                                 ? SVt_PVHV
5607                                 : SVt_PVGV);
5608         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5609         if (gv) {
5610             kid->op_type = OP_GV;
5611             SvREFCNT_dec(kid->op_sv);
5612 #ifdef USE_ITHREADS
5613             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5614             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5615             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5616             GvIN_PAD_on(gv);
5617             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5618 #else
5619             kid->op_sv = SvREFCNT_inc(gv);
5620 #endif
5621             kid->op_private = 0;
5622             kid->op_ppaddr = PL_ppaddr[OP_GV];
5623         }
5624     }
5625     return o;
5626 }
5627
5628 OP *
5629 Perl_ck_ftst(pTHX_ OP *o)
5630 {
5631     I32 type = o->op_type;
5632
5633     if (o->op_flags & OPf_REF) {
5634         /* nothing */
5635     }
5636     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5637         SVOP *kid = (SVOP*)cUNOPo->op_first;
5638
5639         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5640             STRLEN n_a;
5641             OP *newop = newGVOP(type, OPf_REF,
5642                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5643             op_free(o);
5644             o = newop;
5645         }
5646     }
5647     else {
5648         op_free(o);
5649         if (type == OP_FTTTY)
5650            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5651                                 SVt_PVIO));
5652         else
5653             o = newUNOP(type, 0, newDEFSVOP());
5654     }
5655     return o;
5656 }
5657
5658 OP *
5659 Perl_ck_fun(pTHX_ OP *o)
5660 {
5661     register OP *kid;
5662     OP **tokid;
5663     OP *sibl;
5664     I32 numargs = 0;
5665     int type = o->op_type;
5666     register I32 oa = PL_opargs[type] >> OASHIFT;
5667
5668     if (o->op_flags & OPf_STACKED) {
5669         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5670             oa &= ~OA_OPTIONAL;
5671         else
5672             return no_fh_allowed(o);
5673     }
5674
5675     if (o->op_flags & OPf_KIDS) {
5676         STRLEN n_a;
5677         tokid = &cLISTOPo->op_first;
5678         kid = cLISTOPo->op_first;
5679         if (kid->op_type == OP_PUSHMARK ||
5680             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5681         {
5682             tokid = &kid->op_sibling;
5683             kid = kid->op_sibling;
5684         }
5685         if (!kid && PL_opargs[type] & OA_DEFGV)
5686             *tokid = kid = newDEFSVOP();
5687
5688         while (oa && kid) {
5689             numargs++;
5690             sibl = kid->op_sibling;
5691             switch (oa & 7) {
5692             case OA_SCALAR:
5693                 /* list seen where single (scalar) arg expected? */
5694                 if (numargs == 1 && !(oa >> 4)
5695                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5696                 {
5697                     return too_many_arguments(o,PL_op_desc[type]);
5698                 }
5699                 scalar(kid);
5700                 break;
5701             case OA_LIST:
5702                 if (oa < 16) {
5703                     kid = 0;
5704                     continue;
5705                 }
5706                 else
5707                     list(kid);
5708                 break;
5709             case OA_AVREF:
5710                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5711                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5712                     Perl_warner(aTHX_ WARN_SYNTAX,
5713                         "Useless use of %s with no values",
5714                         PL_op_desc[type]);
5715
5716                 if (kid->op_type == OP_CONST &&
5717                     (kid->op_private & OPpCONST_BARE))
5718                 {
5719                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5720                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5721                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5722                     if (ckWARN(WARN_DEPRECATED))
5723                         Perl_warner(aTHX_ WARN_DEPRECATED,
5724                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5725                             name, (IV)numargs, PL_op_desc[type]);
5726                     op_free(kid);
5727                     kid = newop;
5728                     kid->op_sibling = sibl;
5729                     *tokid = kid;
5730                 }
5731                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5732                     bad_type(numargs, "array", PL_op_desc[type], kid);
5733                 mod(kid, type);
5734                 break;
5735             case OA_HVREF:
5736                 if (kid->op_type == OP_CONST &&
5737                     (kid->op_private & OPpCONST_BARE))
5738                 {
5739                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5740                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5741                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5742                     if (ckWARN(WARN_DEPRECATED))
5743                         Perl_warner(aTHX_ WARN_DEPRECATED,
5744                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5745                             name, (IV)numargs, PL_op_desc[type]);
5746                     op_free(kid);
5747                     kid = newop;
5748                     kid->op_sibling = sibl;
5749                     *tokid = kid;
5750                 }
5751                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5752                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5753                 mod(kid, type);
5754                 break;
5755             case OA_CVREF:
5756                 {
5757                     OP *newop = newUNOP(OP_NULL, 0, kid);
5758                     kid->op_sibling = 0;
5759                     linklist(kid);
5760                     newop->op_next = newop;
5761                     kid = newop;
5762                     kid->op_sibling = sibl;
5763                     *tokid = kid;
5764                 }
5765                 break;
5766             case OA_FILEREF:
5767                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5768                     if (kid->op_type == OP_CONST &&
5769                         (kid->op_private & OPpCONST_BARE))
5770                     {
5771                         OP *newop = newGVOP(OP_GV, 0,
5772                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5773                                         SVt_PVIO) );
5774                         op_free(kid);
5775                         kid = newop;
5776                     }
5777                     else if (kid->op_type == OP_READLINE) {
5778                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5779                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5780                     }
5781                     else {
5782                         I32 flags = OPf_SPECIAL;
5783                         I32 priv = 0;
5784                         PADOFFSET targ = 0;
5785
5786                         /* is this op a FH constructor? */
5787                         if (is_handle_constructor(o,numargs)) {
5788                             char *name = Nullch;
5789                             STRLEN len;
5790
5791                             flags = 0;
5792                             /* Set a flag to tell rv2gv to vivify
5793                              * need to "prove" flag does not mean something
5794                              * else already - NI-S 1999/05/07
5795                              */
5796                             priv = OPpDEREF;
5797                             if (kid->op_type == OP_PADSV) {
5798                                 SV **namep = av_fetch(PL_comppad_name,
5799                                                       kid->op_targ, 4);
5800                                 if (namep && *namep)
5801                                     name = SvPV(*namep, len);
5802                             }
5803                             else if (kid->op_type == OP_RV2SV
5804                                      && kUNOP->op_first->op_type == OP_GV)
5805                             {
5806                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5807                                 name = GvNAME(gv);
5808                                 len = GvNAMELEN(gv);
5809                             }
5810                             else if (kid->op_type == OP_AELEM
5811                                      || kid->op_type == OP_HELEM)
5812                             {
5813                                 name = "__ANONIO__";
5814                                 len = 10;
5815                                 mod(kid,type);
5816                             }
5817                             if (name) {
5818                                 SV *namesv;
5819                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5820                                 namesv = PL_curpad[targ];
5821                                 (void)SvUPGRADE(namesv, SVt_PV);
5822                                 if (*name != '$')
5823                                     sv_setpvn(namesv, "$", 1);
5824                                 sv_catpvn(namesv, name, len);
5825                             }
5826                         }
5827                         kid->op_sibling = 0;
5828                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5829                         kid->op_targ = targ;
5830                         kid->op_private |= priv;
5831                     }
5832                     kid->op_sibling = sibl;
5833                     *tokid = kid;
5834                 }
5835                 scalar(kid);
5836                 break;
5837             case OA_SCALARREF:
5838                 mod(scalar(kid), type);
5839                 break;
5840             }
5841             oa >>= 4;
5842             tokid = &kid->op_sibling;
5843             kid = kid->op_sibling;
5844         }
5845         o->op_private |= numargs;
5846         if (kid)
5847             return too_many_arguments(o,PL_op_desc[o->op_type]);
5848         listkids(o);
5849     }
5850     else if (PL_opargs[type] & OA_DEFGV) {
5851         op_free(o);
5852         return newUNOP(type, 0, newDEFSVOP());
5853     }
5854
5855     if (oa) {
5856         while (oa & OA_OPTIONAL)
5857             oa >>= 4;
5858         if (oa && oa != OA_LIST)
5859             return too_few_arguments(o,PL_op_desc[o->op_type]);
5860     }
5861     return o;
5862 }
5863
5864 OP *
5865 Perl_ck_glob(pTHX_ OP *o)
5866 {
5867     GV *gv;
5868
5869     o = ck_fun(o);
5870     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5871         append_elem(OP_GLOB, o, newDEFSVOP());
5872
5873     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5874         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5875
5876 #if !defined(PERL_EXTERNAL_GLOB)
5877     /* XXX this can be tightened up and made more failsafe. */
5878     if (!gv) {
5879         GV *glob_gv;
5880         ENTER;
5881         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5882                          Nullsv, Nullsv);
5883         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5884         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5885         GvCV(gv) = GvCV(glob_gv);
5886         SvREFCNT_inc((SV*)GvCV(gv));
5887         GvIMPORTED_CV_on(gv);
5888         LEAVE;
5889     }
5890 #endif /* PERL_EXTERNAL_GLOB */
5891
5892     if (gv && GvIMPORTED_CV(gv)) {
5893         append_elem(OP_GLOB, o,
5894                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5895         o->op_type = OP_LIST;
5896         o->op_ppaddr = PL_ppaddr[OP_LIST];
5897         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5898         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5899         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5900                     append_elem(OP_LIST, o,
5901                                 scalar(newUNOP(OP_RV2CV, 0,
5902                                                newGVOP(OP_GV, 0, gv)))));
5903         o = newUNOP(OP_NULL, 0, ck_subr(o));
5904         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5905         return o;
5906     }
5907     gv = newGVgen("main");
5908     gv_IOadd(gv);
5909     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5910     scalarkids(o);
5911     return o;
5912 }
5913
5914 OP *
5915 Perl_ck_grep(pTHX_ OP *o)
5916 {
5917     LOGOP *gwop;
5918     OP *kid;
5919     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5920
5921     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5922     NewOp(1101, gwop, 1, LOGOP);
5923
5924     if (o->op_flags & OPf_STACKED) {
5925         OP* k;
5926         o = ck_sort(o);
5927         kid = cLISTOPo->op_first->op_sibling;
5928         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5929             kid = k;
5930         }
5931         kid->op_next = (OP*)gwop;
5932         o->op_flags &= ~OPf_STACKED;
5933     }
5934     kid = cLISTOPo->op_first->op_sibling;
5935     if (type == OP_MAPWHILE)
5936         list(kid);
5937     else
5938         scalar(kid);
5939     o = ck_fun(o);
5940     if (PL_error_count)
5941         return o;
5942     kid = cLISTOPo->op_first->op_sibling;
5943     if (kid->op_type != OP_NULL)
5944         Perl_croak(aTHX_ "panic: ck_grep");
5945     kid = kUNOP->op_first;
5946
5947     gwop->op_type = type;
5948     gwop->op_ppaddr = PL_ppaddr[type];
5949     gwop->op_first = listkids(o);
5950     gwop->op_flags |= OPf_KIDS;
5951     gwop->op_private = 1;
5952     gwop->op_other = LINKLIST(kid);
5953     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5954     kid->op_next = (OP*)gwop;
5955
5956     kid = cLISTOPo->op_first->op_sibling;
5957     if (!kid || !kid->op_sibling)
5958         return too_few_arguments(o,PL_op_desc[o->op_type]);
5959     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5960         mod(kid, OP_GREPSTART);
5961
5962     return (OP*)gwop;
5963 }
5964
5965 OP *
5966 Perl_ck_index(pTHX_ OP *o)
5967 {
5968     if (o->op_flags & OPf_KIDS) {
5969         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5970         if (kid)
5971             kid = kid->op_sibling;                      /* get past "big" */
5972         if (kid && kid->op_type == OP_CONST)
5973             fbm_compile(((SVOP*)kid)->op_sv, 0);
5974     }
5975     return ck_fun(o);
5976 }
5977
5978 OP *
5979 Perl_ck_lengthconst(pTHX_ OP *o)
5980 {
5981     /* XXX length optimization goes here */
5982     return ck_fun(o);
5983 }
5984
5985 OP *
5986 Perl_ck_lfun(pTHX_ OP *o)
5987 {
5988     OPCODE type = o->op_type;
5989     return modkids(ck_fun(o), type);
5990 }
5991
5992 OP *
5993 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5994 {
5995     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5996         switch (cUNOPo->op_first->op_type) {
5997         case OP_RV2AV:
5998             /* This is needed for
5999                if (defined %stash::)
6000                to work.   Do not break Tk.
6001                */
6002             break;                      /* Globals via GV can be undef */
6003         case OP_PADAV:
6004         case OP_AASSIGN:                /* Is this a good idea? */
6005             Perl_warner(aTHX_ WARN_DEPRECATED,
6006                         "defined(@array) is deprecated");
6007             Perl_warner(aTHX_ WARN_DEPRECATED,
6008                         "\t(Maybe you should just omit the defined()?)\n");
6009         break;
6010         case OP_RV2HV:
6011             /* This is needed for
6012                if (defined %stash::)
6013                to work.   Do not break Tk.
6014                */
6015             break;                      /* Globals via GV can be undef */
6016         case OP_PADHV:
6017             Perl_warner(aTHX_ WARN_DEPRECATED,
6018                         "defined(%%hash) is deprecated");
6019             Perl_warner(aTHX_ WARN_DEPRECATED,
6020                         "\t(Maybe you should just omit the defined()?)\n");
6021             break;
6022         default:
6023             /* no warning */
6024             break;
6025         }
6026     }
6027     return ck_rfun(o);
6028 }
6029
6030 OP *
6031 Perl_ck_rfun(pTHX_ OP *o)
6032 {
6033     OPCODE type = o->op_type;
6034     return refkids(ck_fun(o), type);
6035 }
6036
6037 OP *
6038 Perl_ck_listiob(pTHX_ OP *o)
6039 {
6040     register OP *kid;
6041
6042     kid = cLISTOPo->op_first;
6043     if (!kid) {
6044         o = force_list(o);
6045         kid = cLISTOPo->op_first;
6046     }
6047     if (kid->op_type == OP_PUSHMARK)
6048         kid = kid->op_sibling;
6049     if (kid && o->op_flags & OPf_STACKED)
6050         kid = kid->op_sibling;
6051     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6052         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6053             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6054             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6055             cLISTOPo->op_first->op_sibling = kid;
6056             cLISTOPo->op_last = kid;
6057             kid = kid->op_sibling;
6058         }
6059     }
6060
6061     if (!kid)
6062         append_elem(o->op_type, o, newDEFSVOP());
6063
6064     return listkids(o);
6065 }
6066
6067 OP *
6068 Perl_ck_sassign(pTHX_ OP *o)
6069 {
6070     OP *kid = cLISTOPo->op_first;
6071     /* has a disposable target? */
6072     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6073         && !(kid->op_flags & OPf_STACKED)
6074         /* Cannot steal the second time! */
6075         && !(kid->op_private & OPpTARGET_MY))
6076     {
6077         OP *kkid = kid->op_sibling;
6078
6079         /* Can just relocate the target. */
6080         if (kkid && kkid->op_type == OP_PADSV
6081             && !(kkid->op_private & OPpLVAL_INTRO))
6082         {
6083             kid->op_targ = kkid->op_targ;
6084             kkid->op_targ = 0;
6085             /* Now we do not need PADSV and SASSIGN. */
6086             kid->op_sibling = o->op_sibling;    /* NULL */
6087             cLISTOPo->op_first = NULL;
6088             op_free(o);
6089             op_free(kkid);
6090             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6091             return kid;
6092         }
6093     }
6094     return o;
6095 }
6096
6097 OP *
6098 Perl_ck_match(pTHX_ OP *o)
6099 {
6100     o->op_private |= OPpRUNTIME;
6101     return o;
6102 }
6103
6104 OP *
6105 Perl_ck_method(pTHX_ OP *o)
6106 {
6107     OP *kid = cUNOPo->op_first;
6108     if (kid->op_type == OP_CONST) {
6109         SV* sv = kSVOP->op_sv;
6110         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6111             OP *cmop;
6112             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6113                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6114             }
6115             else {
6116                 kSVOP->op_sv = Nullsv;
6117             }
6118             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6119             op_free(o);
6120             return cmop;
6121         }
6122     }
6123     return o;
6124 }
6125
6126 OP *
6127 Perl_ck_null(pTHX_ OP *o)
6128 {
6129     return o;
6130 }
6131
6132 OP *
6133 Perl_ck_open(pTHX_ OP *o)
6134 {
6135     HV *table = GvHV(PL_hintgv);
6136     if (table) {
6137         SV **svp;
6138         I32 mode;
6139         svp = hv_fetch(table, "open_IN", 7, FALSE);
6140         if (svp && *svp) {
6141             mode = mode_from_discipline(*svp);
6142             if (mode & O_BINARY)
6143                 o->op_private |= OPpOPEN_IN_RAW;
6144             else if (mode & O_TEXT)
6145                 o->op_private |= OPpOPEN_IN_CRLF;
6146         }
6147
6148         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6149         if (svp && *svp) {
6150             mode = mode_from_discipline(*svp);
6151             if (mode & O_BINARY)
6152                 o->op_private |= OPpOPEN_OUT_RAW;
6153             else if (mode & O_TEXT)
6154                 o->op_private |= OPpOPEN_OUT_CRLF;
6155         }
6156     }
6157     if (o->op_type == OP_BACKTICK)
6158         return o;
6159     return ck_fun(o);
6160 }
6161
6162 OP *
6163 Perl_ck_repeat(pTHX_ OP *o)
6164 {
6165     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6166         o->op_private |= OPpREPEAT_DOLIST;
6167         cBINOPo->op_first = force_list(cBINOPo->op_first);
6168     }
6169     else
6170         scalar(o);
6171     return o;
6172 }
6173
6174 OP *
6175 Perl_ck_require(pTHX_ OP *o)
6176 {
6177     GV* gv;
6178
6179     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6180         SVOP *kid = (SVOP*)cUNOPo->op_first;
6181
6182         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6183             char *s;
6184             for (s = SvPVX(kid->op_sv); *s; s++) {
6185                 if (*s == ':' && s[1] == ':') {
6186                     *s = '/';
6187                     Move(s+2, s+1, strlen(s+2)+1, char);
6188                     --SvCUR(kid->op_sv);
6189                 }
6190             }
6191             if (SvREADONLY(kid->op_sv)) {
6192                 SvREADONLY_off(kid->op_sv);
6193                 sv_catpvn(kid->op_sv, ".pm", 3);
6194                 SvREADONLY_on(kid->op_sv);
6195             }
6196             else
6197                 sv_catpvn(kid->op_sv, ".pm", 3);
6198         }
6199     }
6200
6201     /* handle override, if any */
6202     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6203     if (!(gv && GvIMPORTED_CV(gv)))
6204         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6205
6206     if (gv && GvIMPORTED_CV(gv)) {
6207         OP *kid = cUNOPo->op_first;
6208         cUNOPo->op_first = 0;
6209         op_free(o);
6210         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6211                                append_elem(OP_LIST, kid,
6212                                            scalar(newUNOP(OP_RV2CV, 0,
6213                                                           newGVOP(OP_GV, 0,
6214                                                                   gv))))));
6215     }
6216
6217     return ck_fun(o);
6218 }
6219
6220 OP *
6221 Perl_ck_return(pTHX_ OP *o)
6222 {
6223     OP *kid;
6224     if (CvLVALUE(PL_compcv)) {
6225         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6226             mod(kid, OP_LEAVESUBLV);
6227     }
6228     return o;
6229 }
6230
6231 #if 0
6232 OP *
6233 Perl_ck_retarget(pTHX_ OP *o)
6234 {
6235     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6236     /* STUB */
6237     return o;
6238 }
6239 #endif
6240
6241 OP *
6242 Perl_ck_select(pTHX_ OP *o)
6243 {
6244     OP* kid;
6245     if (o->op_flags & OPf_KIDS) {
6246         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6247         if (kid && kid->op_sibling) {
6248             o->op_type = OP_SSELECT;
6249             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6250             o = ck_fun(o);
6251             return fold_constants(o);
6252         }
6253     }
6254     o = ck_fun(o);
6255     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6256     if (kid && kid->op_type == OP_RV2GV)
6257         kid->op_private &= ~HINT_STRICT_REFS;
6258     return o;
6259 }
6260
6261 OP *
6262 Perl_ck_shift(pTHX_ OP *o)
6263 {
6264     I32 type = o->op_type;
6265
6266     if (!(o->op_flags & OPf_KIDS)) {
6267         OP *argop;
6268
6269         op_free(o);
6270 #ifdef USE_THREADS
6271         if (!CvUNIQUE(PL_compcv)) {
6272             argop = newOP(OP_PADAV, OPf_REF);
6273             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6274         }
6275         else {
6276             argop = newUNOP(OP_RV2AV, 0,
6277                 scalar(newGVOP(OP_GV, 0,
6278                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6279         }
6280 #else
6281         argop = newUNOP(OP_RV2AV, 0,
6282             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6283                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6284 #endif /* USE_THREADS */
6285         return newUNOP(type, 0, scalar(argop));
6286     }
6287     return scalar(modkids(ck_fun(o), type));
6288 }
6289
6290 OP *
6291 Perl_ck_sort(pTHX_ OP *o)
6292 {
6293     OP *firstkid;
6294
6295     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6296         simplify_sort(o);
6297     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6298     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6299         OP *k = NULL;
6300         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6301
6302         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6303             linklist(kid);
6304             if (kid->op_type == OP_SCOPE) {
6305                 k = kid->op_next;
6306                 kid->op_next = 0;
6307             }
6308             else if (kid->op_type == OP_LEAVE) {
6309                 if (o->op_type == OP_SORT) {
6310                     op_null(kid);                       /* wipe out leave */
6311                     kid->op_next = kid;
6312
6313                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6314                         if (k->op_next == kid)
6315                             k->op_next = 0;
6316                         /* don't descend into loops */
6317                         else if (k->op_type == OP_ENTERLOOP
6318                                  || k->op_type == OP_ENTERITER)
6319                         {
6320                             k = cLOOPx(k)->op_lastop;
6321                         }
6322                     }
6323                 }
6324                 else
6325                     kid->op_next = 0;           /* just disconnect the leave */
6326                 k = kLISTOP->op_first;
6327             }
6328             peep(k);
6329
6330             kid = firstkid;
6331             if (o->op_type == OP_SORT) {
6332                 /* provide scalar context for comparison function/block */
6333                 kid = scalar(kid);
6334                 kid->op_next = kid;
6335             }
6336             else
6337                 kid->op_next = k;
6338             o->op_flags |= OPf_SPECIAL;
6339         }
6340         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6341             op_null(firstkid);
6342
6343         firstkid = firstkid->op_sibling;
6344     }
6345
6346     /* provide list context for arguments */
6347     if (o->op_type == OP_SORT)
6348         list(firstkid);
6349
6350     return o;
6351 }
6352
6353 STATIC void
6354 S_simplify_sort(pTHX_ OP *o)
6355 {
6356     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6357     OP *k;
6358     int reversed;
6359     GV *gv;
6360     if (!(o->op_flags & OPf_STACKED))
6361         return;
6362     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6363     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6364     kid = kUNOP->op_first;                              /* get past null */
6365     if (kid->op_type != OP_SCOPE)
6366         return;
6367     kid = kLISTOP->op_last;                             /* get past scope */
6368     switch(kid->op_type) {
6369         case OP_NCMP:
6370         case OP_I_NCMP:
6371         case OP_SCMP:
6372             break;
6373         default:
6374             return;
6375     }
6376     k = kid;                                            /* remember this node*/
6377     if (kBINOP->op_first->op_type != OP_RV2SV)
6378         return;
6379     kid = kBINOP->op_first;                             /* get past cmp */
6380     if (kUNOP->op_first->op_type != OP_GV)
6381         return;
6382     kid = kUNOP->op_first;                              /* get past rv2sv */
6383     gv = kGVOP_gv;
6384     if (GvSTASH(gv) != PL_curstash)
6385         return;
6386     if (strEQ(GvNAME(gv), "a"))
6387         reversed = 0;
6388     else if (strEQ(GvNAME(gv), "b"))
6389         reversed = 1;
6390     else
6391         return;
6392     kid = k;                                            /* back to cmp */
6393     if (kBINOP->op_last->op_type != OP_RV2SV)
6394         return;
6395     kid = kBINOP->op_last;                              /* down to 2nd arg */
6396     if (kUNOP->op_first->op_type != OP_GV)
6397         return;
6398     kid = kUNOP->op_first;                              /* get past rv2sv */
6399     gv = kGVOP_gv;
6400     if (GvSTASH(gv) != PL_curstash
6401         || ( reversed
6402             ? strNE(GvNAME(gv), "a")
6403             : strNE(GvNAME(gv), "b")))
6404         return;
6405     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6406     if (reversed)
6407         o->op_private |= OPpSORT_REVERSE;
6408     if (k->op_type == OP_NCMP)
6409         o->op_private |= OPpSORT_NUMERIC;
6410     if (k->op_type == OP_I_NCMP)
6411         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6412     kid = cLISTOPo->op_first->op_sibling;
6413     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6414     op_free(kid);                                     /* then delete it */
6415 }
6416
6417 OP *
6418 Perl_ck_split(pTHX_ OP *o)
6419 {
6420     register OP *kid;
6421
6422     if (o->op_flags & OPf_STACKED)
6423         return no_fh_allowed(o);
6424
6425     kid = cLISTOPo->op_first;
6426     if (kid->op_type != OP_NULL)
6427         Perl_croak(aTHX_ "panic: ck_split");
6428     kid = kid->op_sibling;
6429     op_free(cLISTOPo->op_first);
6430     cLISTOPo->op_first = kid;
6431     if (!kid) {
6432         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6433         cLISTOPo->op_last = kid; /* There was only one element previously */
6434     }
6435
6436     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6437         OP *sibl = kid->op_sibling;
6438         kid->op_sibling = 0;
6439         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6440         if (cLISTOPo->op_first == cLISTOPo->op_last)
6441             cLISTOPo->op_last = kid;
6442         cLISTOPo->op_first = kid;
6443         kid->op_sibling = sibl;
6444     }
6445
6446     kid->op_type = OP_PUSHRE;
6447     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6448     scalar(kid);
6449
6450     if (!kid->op_sibling)
6451         append_elem(OP_SPLIT, o, newDEFSVOP());
6452
6453     kid = kid->op_sibling;
6454     scalar(kid);
6455
6456     if (!kid->op_sibling)
6457         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6458
6459     kid = kid->op_sibling;
6460     scalar(kid);
6461
6462     if (kid->op_sibling)
6463         return too_many_arguments(o,PL_op_desc[o->op_type]);
6464
6465     return o;
6466 }
6467
6468 OP *
6469 Perl_ck_join(pTHX_ OP *o)
6470 {
6471     if (ckWARN(WARN_SYNTAX)) {
6472         OP *kid = cLISTOPo->op_first->op_sibling;
6473         if (kid && kid->op_type == OP_MATCH) {
6474             char *pmstr = "STRING";
6475             if (PM_GETRE(kPMOP))
6476                 pmstr = PM_GETRE(kPMOP)->precomp;
6477             Perl_warner(aTHX_ WARN_SYNTAX,
6478                         "/%s/ should probably be written as \"%s\"",
6479                         pmstr, pmstr);
6480         }
6481     }
6482     return ck_fun(o);
6483 }
6484
6485 OP *
6486 Perl_ck_subr(pTHX_ OP *o)
6487 {
6488     OP *prev = ((cUNOPo->op_first->op_sibling)
6489              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6490     OP *o2 = prev->op_sibling;
6491     OP *cvop;
6492     char *proto = 0;
6493     CV *cv = 0;
6494     GV *namegv = 0;
6495     int optional = 0;
6496     I32 arg = 0;
6497     STRLEN n_a;
6498
6499     o->op_private |= OPpENTERSUB_HASTARG;
6500     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6501     if (cvop->op_type == OP_RV2CV) {
6502         SVOP* tmpop;
6503         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6504         op_null(cvop);          /* disable rv2cv */
6505         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6506         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6507             GV *gv = cGVOPx_gv(tmpop);
6508             cv = GvCVu(gv);
6509             if (!cv)
6510                 tmpop->op_private |= OPpEARLY_CV;
6511             else if (SvPOK(cv)) {
6512                 namegv = CvANON(cv) ? gv : CvGV(cv);
6513                 proto = SvPV((SV*)cv, n_a);
6514             }
6515         }
6516     }
6517     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6518         if (o2->op_type == OP_CONST)
6519             o2->op_private &= ~OPpCONST_STRICT;
6520         else if (o2->op_type == OP_LIST) {
6521             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6522             if (o && o->op_type == OP_CONST)
6523                 o->op_private &= ~OPpCONST_STRICT;
6524         }
6525     }
6526     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6527     if (PERLDB_SUB && PL_curstash != PL_debstash)
6528         o->op_private |= OPpENTERSUB_DB;
6529     while (o2 != cvop) {
6530         if (proto) {
6531             switch (*proto) {
6532             case '\0':
6533                 return too_many_arguments(o, gv_ename(namegv));
6534             case ';':
6535                 optional = 1;
6536                 proto++;
6537                 continue;
6538             case '$':
6539                 proto++;
6540                 arg++;
6541                 scalar(o2);
6542                 break;
6543             case '%':
6544             case '@':
6545                 list(o2);
6546                 arg++;
6547                 break;
6548             case '&':
6549                 proto++;
6550                 arg++;
6551                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6552                     bad_type(arg,
6553                         arg == 1 ? "block or sub {}" : "sub {}",
6554                         gv_ename(namegv), o2);
6555                 break;
6556             case '*':
6557                 /* '*' allows any scalar type, including bareword */
6558                 proto++;
6559                 arg++;
6560                 if (o2->op_type == OP_RV2GV)
6561                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6562                 else if (o2->op_type == OP_CONST)
6563                     o2->op_private &= ~OPpCONST_STRICT;
6564                 else if (o2->op_type == OP_ENTERSUB) {
6565                     /* accidental subroutine, revert to bareword */
6566                     OP *gvop = ((UNOP*)o2)->op_first;
6567                     if (gvop && gvop->op_type == OP_NULL) {
6568                         gvop = ((UNOP*)gvop)->op_first;
6569                         if (gvop) {
6570                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6571                                 ;
6572                             if (gvop &&
6573                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6574                                 (gvop = ((UNOP*)gvop)->op_first) &&
6575                                 gvop->op_type == OP_GV)
6576                             {
6577                                 GV *gv = cGVOPx_gv(gvop);
6578                                 OP *sibling = o2->op_sibling;
6579                                 SV *n = newSVpvn("",0);
6580                                 op_free(o2);
6581                                 gv_fullname3(n, gv, "");
6582                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6583                                     sv_chop(n, SvPVX(n)+6);
6584                                 o2 = newSVOP(OP_CONST, 0, n);
6585                                 prev->op_sibling = o2;
6586                                 o2->op_sibling = sibling;
6587                             }
6588                         }
6589                     }
6590                 }
6591                 scalar(o2);
6592                 break;
6593             case '\\':
6594                 proto++;
6595                 arg++;
6596                 switch (*proto++) {
6597                 case '*':
6598                     if (o2->op_type != OP_RV2GV)
6599                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6600                     goto wrapref;
6601                 case '&':
6602                     if (o2->op_type != OP_ENTERSUB)
6603                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6604                     goto wrapref;
6605                 case '$':
6606                     if (o2->op_type != OP_RV2SV
6607                         && o2->op_type != OP_PADSV
6608                         && o2->op_type != OP_HELEM
6609                         && o2->op_type != OP_AELEM
6610                         && o2->op_type != OP_THREADSV)
6611                     {
6612                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6613                     }
6614                     goto wrapref;
6615                 case '@':
6616                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6617                         bad_type(arg, "array", gv_ename(namegv), o2);
6618                     goto wrapref;
6619                 case '%':
6620                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6621                         bad_type(arg, "hash", gv_ename(namegv), o2);
6622                   wrapref:
6623                     {
6624                         OP* kid = o2;
6625                         OP* sib = kid->op_sibling;
6626                         kid->op_sibling = 0;
6627                         o2 = newUNOP(OP_REFGEN, 0, kid);
6628                         o2->op_sibling = sib;
6629                         prev->op_sibling = o2;
6630                     }
6631                     break;
6632                 default: goto oops;
6633                 }
6634                 break;
6635             case ' ':
6636                 proto++;
6637                 continue;
6638             default:
6639               oops:
6640                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6641                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6642             }
6643         }
6644         else
6645             list(o2);
6646         mod(o2, OP_ENTERSUB);
6647         prev = o2;
6648         o2 = o2->op_sibling;
6649     }
6650     if (proto && !optional &&
6651           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6652         return too_few_arguments(o, gv_ename(namegv));
6653     return o;
6654 }
6655
6656 OP *
6657 Perl_ck_svconst(pTHX_ OP *o)
6658 {
6659     SvREADONLY_on(cSVOPo->op_sv);
6660     return o;
6661 }
6662
6663 OP *
6664 Perl_ck_trunc(pTHX_ OP *o)
6665 {
6666     if (o->op_flags & OPf_KIDS) {
6667         SVOP *kid = (SVOP*)cUNOPo->op_first;
6668
6669         if (kid->op_type == OP_NULL)
6670             kid = (SVOP*)kid->op_sibling;
6671         if (kid && kid->op_type == OP_CONST &&
6672             (kid->op_private & OPpCONST_BARE))
6673         {
6674             o->op_flags |= OPf_SPECIAL;
6675             kid->op_private &= ~OPpCONST_STRICT;
6676         }
6677     }
6678     return ck_fun(o);
6679 }
6680
6681 OP *
6682 Perl_ck_substr(pTHX_ OP *o)
6683 {
6684     o = ck_fun(o);
6685     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6686         OP *kid = cLISTOPo->op_first;
6687
6688         if (kid->op_type == OP_NULL)
6689             kid = kid->op_sibling;
6690         if (kid)
6691             kid->op_flags |= OPf_MOD;
6692
6693     }
6694     return o;
6695 }
6696
6697 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6698
6699 void
6700 Perl_peep(pTHX_ register OP *o)
6701 {
6702     register OP* oldop = 0;
6703     STRLEN n_a;
6704
6705     if (!o || o->op_seq)
6706         return;
6707     ENTER;
6708     SAVEOP();
6709     SAVEVPTR(PL_curcop);
6710     for (; o; o = o->op_next) {
6711         if (o->op_seq)
6712             break;
6713         if (!PL_op_seqmax)
6714             PL_op_seqmax++;
6715         PL_op = o;
6716         switch (o->op_type) {
6717         case OP_SETSTATE:
6718         case OP_NEXTSTATE:
6719         case OP_DBSTATE:
6720             PL_curcop = ((COP*)o);              /* for warnings */
6721             o->op_seq = PL_op_seqmax++;
6722             break;
6723
6724         case OP_CONST:
6725             if (cSVOPo->op_private & OPpCONST_STRICT)
6726                 no_bareword_allowed(o);
6727 #ifdef USE_ITHREADS
6728             /* Relocate sv to the pad for thread safety.
6729              * Despite being a "constant", the SV is written to,
6730              * for reference counts, sv_upgrade() etc. */
6731             if (cSVOP->op_sv) {
6732                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6733                 if (SvPADTMP(cSVOPo->op_sv)) {
6734                     /* If op_sv is already a PADTMP then it is being used by
6735                      * some pad, so make a copy. */
6736                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6737                     SvREADONLY_on(PL_curpad[ix]);
6738                     SvREFCNT_dec(cSVOPo->op_sv);
6739                 }
6740                 else {
6741                     SvREFCNT_dec(PL_curpad[ix]);
6742                     SvPADTMP_on(cSVOPo->op_sv);
6743                     PL_curpad[ix] = cSVOPo->op_sv;
6744                     /* XXX I don't know how this isn't readonly already. */
6745                     SvREADONLY_on(PL_curpad[ix]);
6746                 }
6747                 cSVOPo->op_sv = Nullsv;
6748                 o->op_targ = ix;
6749             }
6750 #endif
6751             o->op_seq = PL_op_seqmax++;
6752             break;
6753
6754         case OP_CONCAT:
6755             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6756                 if (o->op_next->op_private & OPpTARGET_MY) {
6757                     if (o->op_flags & OPf_STACKED) /* chained concats */
6758                         goto ignore_optimization;
6759                     else {
6760                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6761                         o->op_targ = o->op_next->op_targ;
6762                         o->op_next->op_targ = 0;
6763                         o->op_private |= OPpTARGET_MY;
6764                     }
6765                 }
6766                 op_null(o->op_next);
6767             }
6768           ignore_optimization:
6769             o->op_seq = PL_op_seqmax++;
6770             break;
6771         case OP_STUB:
6772             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6773                 o->op_seq = PL_op_seqmax++;
6774                 break; /* Scalar stub must produce undef.  List stub is noop */
6775             }
6776             goto nothin;
6777         case OP_NULL:
6778             if (o->op_targ == OP_NEXTSTATE
6779                 || o->op_targ == OP_DBSTATE
6780                 || o->op_targ == OP_SETSTATE)
6781             {
6782                 PL_curcop = ((COP*)o);
6783             }
6784             /* XXX: We avoid setting op_seq here to prevent later calls
6785                to peep() from mistakenly concluding that optimisation
6786                has already occurred. This doesn't fix the real problem,
6787                though (See 20010220.007). AMS 20010719 */
6788             if (oldop && o->op_next) {
6789                 oldop->op_next = o->op_next;
6790                 continue;
6791             }
6792             break;
6793         case OP_SCALAR:
6794         case OP_LINESEQ:
6795         case OP_SCOPE:
6796           nothin:
6797             if (oldop && o->op_next) {
6798                 oldop->op_next = o->op_next;
6799                 continue;
6800             }
6801             o->op_seq = PL_op_seqmax++;
6802             break;
6803
6804         case OP_GV:
6805             if (o->op_next->op_type == OP_RV2SV) {
6806                 if (!(o->op_next->op_private & OPpDEREF)) {
6807                     op_null(o->op_next);
6808                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6809                                                                | OPpOUR_INTRO);
6810                     o->op_next = o->op_next->op_next;
6811                     o->op_type = OP_GVSV;
6812                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6813                 }
6814             }
6815             else if (o->op_next->op_type == OP_RV2AV) {
6816                 OP* pop = o->op_next->op_next;
6817                 IV i;
6818                 if (pop->op_type == OP_CONST &&
6819                     (PL_op = pop->op_next) &&
6820                     pop->op_next->op_type == OP_AELEM &&
6821                     !(pop->op_next->op_private &
6822                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6823                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6824                                 <= 255 &&
6825                     i >= 0)
6826                 {
6827                     GV *gv;
6828                     op_null(o->op_next);
6829                     op_null(pop->op_next);
6830                     op_null(pop);
6831                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6832                     o->op_next = pop->op_next->op_next;
6833                     o->op_type = OP_AELEMFAST;
6834                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6835                     o->op_private = (U8)i;
6836                     gv = cGVOPo_gv;
6837                     GvAVn(gv);
6838                 }
6839             }
6840             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6841                 GV *gv = cGVOPo_gv;
6842                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6843                     /* XXX could check prototype here instead of just carping */
6844                     SV *sv = sv_newmortal();
6845                     gv_efullname3(sv, gv, Nullch);
6846                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6847                                 "%s() called too early to check prototype",
6848                                 SvPV_nolen(sv));
6849                 }
6850             }
6851
6852             o->op_seq = PL_op_seqmax++;
6853             break;
6854
6855         case OP_MAPWHILE:
6856         case OP_GREPWHILE:
6857         case OP_AND:
6858         case OP_OR:
6859         case OP_ANDASSIGN:
6860         case OP_ORASSIGN:
6861         case OP_COND_EXPR:
6862         case OP_RANGE:
6863             o->op_seq = PL_op_seqmax++;
6864             while (cLOGOP->op_other->op_type == OP_NULL)
6865                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6866             peep(cLOGOP->op_other);
6867             break;
6868
6869         case OP_ENTERLOOP:
6870         case OP_ENTERITER:
6871             o->op_seq = PL_op_seqmax++;
6872             while (cLOOP->op_redoop->op_type == OP_NULL)
6873                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6874             peep(cLOOP->op_redoop);
6875             while (cLOOP->op_nextop->op_type == OP_NULL)
6876                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6877             peep(cLOOP->op_nextop);
6878             while (cLOOP->op_lastop->op_type == OP_NULL)
6879                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6880             peep(cLOOP->op_lastop);
6881             break;
6882
6883         case OP_QR:
6884         case OP_MATCH:
6885         case OP_SUBST:
6886             o->op_seq = PL_op_seqmax++;
6887             while (cPMOP->op_pmreplstart &&
6888                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6889                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6890             peep(cPMOP->op_pmreplstart);
6891             break;
6892
6893         case OP_EXEC:
6894             o->op_seq = PL_op_seqmax++;
6895             if (ckWARN(WARN_SYNTAX) && o->op_next
6896                 && o->op_next->op_type == OP_NEXTSTATE) {
6897                 if (o->op_next->op_sibling &&
6898                         o->op_next->op_sibling->op_type != OP_EXIT &&
6899                         o->op_next->op_sibling->op_type != OP_WARN &&
6900                         o->op_next->op_sibling->op_type != OP_DIE) {
6901                     line_t oldline = CopLINE(PL_curcop);
6902
6903                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6904                     Perl_warner(aTHX_ WARN_EXEC,
6905                                 "Statement unlikely to be reached");
6906                     Perl_warner(aTHX_ WARN_EXEC,
6907                                 "\t(Maybe you meant system() when you said exec()?)\n");
6908                     CopLINE_set(PL_curcop, oldline);
6909                 }
6910             }
6911             break;
6912
6913         case OP_HELEM: {
6914             UNOP *rop;
6915             SV *lexname;
6916             GV **fields;
6917             SV **svp, **indsvp, *sv;
6918             I32 ind;
6919             char *key = NULL;
6920             STRLEN keylen;
6921
6922             o->op_seq = PL_op_seqmax++;
6923
6924             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6925                 break;
6926
6927             /* Make the CONST have a shared SV */
6928             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6929             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6930                 key = SvPV(sv, keylen);
6931                 lexname = newSVpvn_share(key,
6932                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6933                                          0);
6934                 SvREFCNT_dec(sv);
6935                 *svp = lexname;
6936             }
6937
6938             if ((o->op_private & (OPpLVAL_INTRO)))
6939                 break;
6940
6941             rop = (UNOP*)((BINOP*)o)->op_first;
6942             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6943                 break;
6944             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6945             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6946                 break;
6947             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6948             if (!fields || !GvHV(*fields))
6949                 break;
6950             key = SvPV(*svp, keylen);
6951             indsvp = hv_fetch(GvHV(*fields), key,
6952                               SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6953             if (!indsvp) {
6954                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6955                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6956             }
6957             ind = SvIV(*indsvp);
6958             if (ind < 1)
6959                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6960             rop->op_type = OP_RV2AV;
6961             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6962             o->op_type = OP_AELEM;
6963             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6964             sv = newSViv(ind);
6965             if (SvREADONLY(*svp))
6966                 SvREADONLY_on(sv);
6967             SvFLAGS(sv) |= (SvFLAGS(*svp)
6968                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6969             SvREFCNT_dec(*svp);
6970             *svp = sv;
6971             break;
6972         }
6973
6974         case OP_HSLICE: {
6975             UNOP *rop;
6976             SV *lexname;
6977             GV **fields;
6978             SV **svp, **indsvp, *sv;
6979             I32 ind;
6980             char *key;
6981             STRLEN keylen;
6982             SVOP *first_key_op, *key_op;
6983
6984             o->op_seq = PL_op_seqmax++;
6985             if ((o->op_private & (OPpLVAL_INTRO))
6986                 /* I bet there's always a pushmark... */
6987                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6988                 /* hmmm, no optimization if list contains only one key. */
6989                 break;
6990             rop = (UNOP*)((LISTOP*)o)->op_last;
6991             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6992                 break;
6993             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6994             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6995                 break;
6996             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6997             if (!fields || !GvHV(*fields))
6998                 break;
6999             /* Again guessing that the pushmark can be jumped over.... */
7000             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7001                 ->op_first->op_sibling;
7002             /* Check that the key list contains only constants. */
7003             for (key_op = first_key_op; key_op;
7004                  key_op = (SVOP*)key_op->op_sibling)
7005                 if (key_op->op_type != OP_CONST)
7006                     break;
7007             if (key_op)
7008                 break;
7009             rop->op_type = OP_RV2AV;
7010             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7011             o->op_type = OP_ASLICE;
7012             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7013             for (key_op = first_key_op; key_op;
7014                  key_op = (SVOP*)key_op->op_sibling) {
7015                 svp = cSVOPx_svp(key_op);
7016                 key = SvPV(*svp, keylen);
7017                 indsvp = hv_fetch(GvHV(*fields), key,
7018                                   SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7019                 if (!indsvp) {
7020                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7021                                "in variable %s of type %s",
7022                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7023                 }
7024                 ind = SvIV(*indsvp);
7025                 if (ind < 1)
7026                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7027                 sv = newSViv(ind);
7028                 if (SvREADONLY(*svp))
7029                     SvREADONLY_on(sv);
7030                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7031                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7032                 SvREFCNT_dec(*svp);
7033                 *svp = sv;
7034             }
7035             break;
7036         }
7037
7038         default:
7039             o->op_seq = PL_op_seqmax++;
7040             break;
7041         }
7042         oldop = o;
7043     }
7044     LEAVE;
7045 }
7046
7047 #include "XSUB.h"
7048
7049 /* Efficient sub that returns a constant scalar value. */
7050 static void
7051 const_sv_xsub(pTHXo_ CV* cv)
7052 {
7053     dXSARGS;
7054     if (items != 0) {
7055 #if 0
7056         Perl_croak(aTHX_ "usage: %s::%s()",
7057                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7058 #endif
7059     }
7060     EXTEND(sp, 1);
7061     ST(0) = (SV*)XSANY.any_ptr;
7062     XSRETURN(1);
7063 }
7064