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     }
4754     else {
4755         cv = PL_compcv;
4756         if (name) {
4757             GvCV(gv) = cv;
4758             GvCVGEN(gv) = 0;
4759             PL_sub_generation++;
4760         }
4761     }
4762     CvGV(cv) = gv;
4763     CvFILE_set_from_cop(cv, PL_curcop);
4764     CvSTASH(cv) = PL_curstash;
4765 #ifdef USE_THREADS
4766     CvOWNER(cv) = 0;
4767     if (!CvMUTEXP(cv)) {
4768         New(666, CvMUTEXP(cv), 1, perl_mutex);
4769         MUTEX_INIT(CvMUTEXP(cv));
4770     }
4771 #endif /* USE_THREADS */
4772
4773     if (ps)
4774         sv_setpv((SV*)cv, ps);
4775
4776     if (PL_error_count) {
4777         op_free(block);
4778         block = Nullop;
4779         if (name) {
4780             char *s = strrchr(name, ':');
4781             s = s ? s+1 : name;
4782             if (strEQ(s, "BEGIN")) {
4783                 char *not_safe =
4784                     "BEGIN not safe after errors--compilation aborted";
4785                 if (PL_in_eval & EVAL_KEEPERR)
4786                     Perl_croak(aTHX_ not_safe);
4787                 else {
4788                     /* force display of errors found but not reported */
4789                     sv_catpv(ERRSV, not_safe);
4790                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4791                 }
4792             }
4793         }
4794     }
4795     if (!block)
4796         goto done;
4797
4798     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4799         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4800
4801     if (CvLVALUE(cv)) {
4802         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4803                              mod(scalarseq(block), OP_LEAVESUBLV));
4804     }
4805     else {
4806         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4807     }
4808     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4809     OpREFCNT_set(CvROOT(cv), 1);
4810     CvSTART(cv) = LINKLIST(CvROOT(cv));
4811     CvROOT(cv)->op_next = 0;
4812     peep(CvSTART(cv));
4813
4814     /* now that optimizer has done its work, adjust pad values */
4815     if (CvCLONE(cv)) {
4816         SV **namep = AvARRAY(PL_comppad_name);
4817         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4818             SV *namesv;
4819
4820             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4821                 continue;
4822             /*
4823              * The only things that a clonable function needs in its
4824              * pad are references to outer lexicals and anonymous subs.
4825              * The rest are created anew during cloning.
4826              */
4827             if (!((namesv = namep[ix]) != Nullsv &&
4828                   namesv != &PL_sv_undef &&
4829                   (SvFAKE(namesv) ||
4830                    *SvPVX(namesv) == '&')))
4831             {
4832                 SvREFCNT_dec(PL_curpad[ix]);
4833                 PL_curpad[ix] = Nullsv;
4834             }
4835         }
4836         assert(!CvCONST(cv));
4837         if (ps && !*ps && op_const_sv(block, cv))
4838             CvCONST_on(cv);
4839     }
4840     else {
4841         AV *av = newAV();                       /* Will be @_ */
4842         av_extend(av, 0);
4843         av_store(PL_comppad, 0, (SV*)av);
4844         AvFLAGS(av) = AVf_REIFY;
4845
4846         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4847             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4848                 continue;
4849             if (!SvPADMY(PL_curpad[ix]))
4850                 SvPADTMP_on(PL_curpad[ix]);
4851         }
4852     }
4853
4854     /* If a potential closure prototype, don't keep a refcount on
4855      * outer CV, unless the latter happens to be a passing eval"".
4856      * This is okay as the lifetime of the prototype is tied to the
4857      * lifetime of the outer CV.  Avoids memory leak due to reference
4858      * loop. --GSAR */
4859     if (!name && CvOUTSIDE(cv)
4860         && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4861              && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4862     {
4863         SvREFCNT_dec(CvOUTSIDE(cv));
4864     }
4865
4866     if (name || aname) {
4867         char *s;
4868         char *tname = (name ? name : aname);
4869
4870         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4871             SV *sv = NEWSV(0,0);
4872             SV *tmpstr = sv_newmortal();
4873             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4874             CV *pcv;
4875             HV *hv;
4876
4877             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4878                            CopFILE(PL_curcop),
4879                            (long)PL_subline, (long)CopLINE(PL_curcop));
4880             gv_efullname3(tmpstr, gv, Nullch);
4881             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4882             hv = GvHVn(db_postponed);
4883             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4884                 && (pcv = GvCV(db_postponed)))
4885             {
4886                 dSP;
4887                 PUSHMARK(SP);
4888                 XPUSHs(tmpstr);
4889                 PUTBACK;
4890                 call_sv((SV*)pcv, G_DISCARD);
4891             }
4892         }
4893
4894         if ((s = strrchr(tname,':')))
4895             s++;
4896         else
4897             s = tname;
4898
4899         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4900             goto done;
4901
4902         if (strEQ(s, "BEGIN")) {
4903             I32 oldscope = PL_scopestack_ix;
4904             ENTER;
4905             SAVECOPFILE(&PL_compiling);
4906             SAVECOPLINE(&PL_compiling);
4907             save_svref(&PL_rs);
4908             sv_setsv(PL_rs, PL_nrs);
4909
4910             if (!PL_beginav)
4911                 PL_beginav = newAV();
4912             DEBUG_x( dump_sub(gv) );
4913             av_push(PL_beginav, (SV*)cv);
4914             GvCV(gv) = 0;               /* cv has been hijacked */
4915             call_list(oldscope, PL_beginav);
4916
4917             PL_curcop = &PL_compiling;
4918             PL_compiling.op_private = PL_hints;
4919             LEAVE;
4920         }
4921         else if (strEQ(s, "END") && !PL_error_count) {
4922             if (!PL_endav)
4923                 PL_endav = newAV();
4924             DEBUG_x( dump_sub(gv) );
4925             av_unshift(PL_endav, 1);
4926             av_store(PL_endav, 0, (SV*)cv);
4927             GvCV(gv) = 0;               /* cv has been hijacked */
4928         }
4929         else if (strEQ(s, "CHECK") && !PL_error_count) {
4930             if (!PL_checkav)
4931                 PL_checkav = newAV();
4932             DEBUG_x( dump_sub(gv) );
4933             if (PL_main_start && ckWARN(WARN_VOID))
4934                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4935             av_unshift(PL_checkav, 1);
4936             av_store(PL_checkav, 0, (SV*)cv);
4937             GvCV(gv) = 0;               /* cv has been hijacked */
4938         }
4939         else if (strEQ(s, "INIT") && !PL_error_count) {
4940             if (!PL_initav)
4941                 PL_initav = newAV();
4942             DEBUG_x( dump_sub(gv) );
4943             if (PL_main_start && ckWARN(WARN_VOID))
4944                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4945             av_push(PL_initav, (SV*)cv);
4946             GvCV(gv) = 0;               /* cv has been hijacked */
4947         }
4948     }
4949
4950   done:
4951     PL_copline = NOLINE;
4952     LEAVE_SCOPE(floor);
4953     return cv;
4954 }
4955
4956 /* XXX unsafe for threads if eval_owner isn't held */
4957 /*
4958 =for apidoc newCONSTSUB
4959
4960 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4961 eligible for inlining at compile-time.
4962
4963 =cut
4964 */
4965
4966 CV *
4967 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4968 {
4969     CV* cv;
4970
4971     ENTER;
4972
4973     SAVECOPLINE(PL_curcop);
4974     CopLINE_set(PL_curcop, PL_copline);
4975
4976     SAVEHINTS();
4977     PL_hints &= ~HINT_BLOCK_SCOPE;
4978
4979     if (stash) {
4980         SAVESPTR(PL_curstash);
4981         SAVECOPSTASH(PL_curcop);
4982         PL_curstash = stash;
4983 #ifdef USE_ITHREADS
4984         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4985 #else
4986         CopSTASH(PL_curcop) = stash;
4987 #endif
4988     }
4989
4990     cv = newXS(name, const_sv_xsub, __FILE__);
4991     CvXSUBANY(cv).any_ptr = sv;
4992     CvCONST_on(cv);
4993     sv_setpv((SV*)cv, "");  /* prototype is "" */
4994
4995     LEAVE;
4996
4997     return cv;
4998 }
4999
5000 /*
5001 =for apidoc U||newXS
5002
5003 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5004
5005 =cut
5006 */
5007
5008 CV *
5009 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5010 {
5011     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5012     register CV *cv;
5013
5014     if ((cv = (name ? GvCV(gv) : Nullcv))) {
5015         if (GvCVGEN(gv)) {
5016             /* just a cached method */
5017             SvREFCNT_dec(cv);
5018             cv = 0;
5019         }
5020         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5021             /* already defined (or promised) */
5022             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5023                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5024                 line_t oldline = CopLINE(PL_curcop);
5025                 if (PL_copline != NOLINE)
5026                     CopLINE_set(PL_curcop, PL_copline);
5027                 Perl_warner(aTHX_ WARN_REDEFINE,
5028                             CvCONST(cv) ? "Constant subroutine %s redefined"
5029                                         : "Subroutine %s redefined"
5030                             ,name);
5031                 CopLINE_set(PL_curcop, oldline);
5032             }
5033             SvREFCNT_dec(cv);
5034             cv = 0;
5035         }
5036     }
5037
5038     if (cv)                             /* must reuse cv if autoloaded */
5039         cv_undef(cv);
5040     else {
5041         cv = (CV*)NEWSV(1105,0);
5042         sv_upgrade((SV *)cv, SVt_PVCV);
5043         if (name) {
5044             GvCV(gv) = cv;
5045             GvCVGEN(gv) = 0;
5046             PL_sub_generation++;
5047         }
5048     }
5049     CvGV(cv) = gv;
5050 #ifdef USE_THREADS
5051     New(666, CvMUTEXP(cv), 1, perl_mutex);
5052     MUTEX_INIT(CvMUTEXP(cv));
5053     CvOWNER(cv) = 0;
5054 #endif /* USE_THREADS */
5055     (void)gv_fetchfile(filename);
5056     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5057                                    an external constant string */
5058     CvXSUB(cv) = subaddr;
5059
5060     if (name) {
5061         char *s = strrchr(name,':');
5062         if (s)
5063             s++;
5064         else
5065             s = name;
5066
5067         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5068             goto done;
5069
5070         if (strEQ(s, "BEGIN")) {
5071             if (!PL_beginav)
5072                 PL_beginav = newAV();
5073             av_push(PL_beginav, (SV*)cv);
5074             GvCV(gv) = 0;               /* cv has been hijacked */
5075         }
5076         else if (strEQ(s, "END")) {
5077             if (!PL_endav)
5078                 PL_endav = newAV();
5079             av_unshift(PL_endav, 1);
5080             av_store(PL_endav, 0, (SV*)cv);
5081             GvCV(gv) = 0;               /* cv has been hijacked */
5082         }
5083         else if (strEQ(s, "CHECK")) {
5084             if (!PL_checkav)
5085                 PL_checkav = newAV();
5086             if (PL_main_start && ckWARN(WARN_VOID))
5087                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5088             av_unshift(PL_checkav, 1);
5089             av_store(PL_checkav, 0, (SV*)cv);
5090             GvCV(gv) = 0;               /* cv has been hijacked */
5091         }
5092         else if (strEQ(s, "INIT")) {
5093             if (!PL_initav)
5094                 PL_initav = newAV();
5095             if (PL_main_start && ckWARN(WARN_VOID))
5096                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5097             av_push(PL_initav, (SV*)cv);
5098             GvCV(gv) = 0;               /* cv has been hijacked */
5099         }
5100     }
5101     else
5102         CvANON_on(cv);
5103
5104 done:
5105     return cv;
5106 }
5107
5108 void
5109 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5110 {
5111     register CV *cv;
5112     char *name;
5113     GV *gv;
5114     I32 ix;
5115     STRLEN n_a;
5116
5117     if (o)
5118         name = SvPVx(cSVOPo->op_sv, n_a);
5119     else
5120         name = "STDOUT";
5121     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5122 #ifdef GV_UNIQUE_CHECK
5123     if (GvUNIQUE(gv)) {
5124         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5125     }
5126 #endif
5127     GvMULTI_on(gv);
5128     if ((cv = GvFORM(gv))) {
5129         if (ckWARN(WARN_REDEFINE)) {
5130             line_t oldline = CopLINE(PL_curcop);
5131
5132             CopLINE_set(PL_curcop, PL_copline);
5133             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5134             CopLINE_set(PL_curcop, oldline);
5135         }
5136         SvREFCNT_dec(cv);
5137     }
5138     cv = PL_compcv;
5139     GvFORM(gv) = cv;
5140     CvGV(cv) = gv;
5141     CvFILE_set_from_cop(cv, PL_curcop);
5142
5143     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5144         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5145             SvPADTMP_on(PL_curpad[ix]);
5146     }
5147
5148     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5149     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5150     OpREFCNT_set(CvROOT(cv), 1);
5151     CvSTART(cv) = LINKLIST(CvROOT(cv));
5152     CvROOT(cv)->op_next = 0;
5153     peep(CvSTART(cv));
5154     op_free(o);
5155     PL_copline = NOLINE;
5156     LEAVE_SCOPE(floor);
5157 }
5158
5159 OP *
5160 Perl_newANONLIST(pTHX_ OP *o)
5161 {
5162     return newUNOP(OP_REFGEN, 0,
5163         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5164 }
5165
5166 OP *
5167 Perl_newANONHASH(pTHX_ OP *o)
5168 {
5169     return newUNOP(OP_REFGEN, 0,
5170         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5171 }
5172
5173 OP *
5174 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5175 {
5176     return newANONATTRSUB(floor, proto, Nullop, block);
5177 }
5178
5179 OP *
5180 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5181 {
5182     return newUNOP(OP_REFGEN, 0,
5183         newSVOP(OP_ANONCODE, 0,
5184                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5185 }
5186
5187 OP *
5188 Perl_oopsAV(pTHX_ OP *o)
5189 {
5190     switch (o->op_type) {
5191     case OP_PADSV:
5192         o->op_type = OP_PADAV;
5193         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5194         return ref(o, OP_RV2AV);
5195
5196     case OP_RV2SV:
5197         o->op_type = OP_RV2AV;
5198         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5199         ref(o, OP_RV2AV);
5200         break;
5201
5202     default:
5203         if (ckWARN_d(WARN_INTERNAL))
5204             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5205         break;
5206     }
5207     return o;
5208 }
5209
5210 OP *
5211 Perl_oopsHV(pTHX_ OP *o)
5212 {
5213     switch (o->op_type) {
5214     case OP_PADSV:
5215     case OP_PADAV:
5216         o->op_type = OP_PADHV;
5217         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5218         return ref(o, OP_RV2HV);
5219
5220     case OP_RV2SV:
5221     case OP_RV2AV:
5222         o->op_type = OP_RV2HV;
5223         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5224         ref(o, OP_RV2HV);
5225         break;
5226
5227     default:
5228         if (ckWARN_d(WARN_INTERNAL))
5229             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5230         break;
5231     }
5232     return o;
5233 }
5234
5235 OP *
5236 Perl_newAVREF(pTHX_ OP *o)
5237 {
5238     if (o->op_type == OP_PADANY) {
5239         o->op_type = OP_PADAV;
5240         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5241         return o;
5242     }
5243     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5244                 && ckWARN(WARN_DEPRECATED)) {
5245         Perl_warner(aTHX_ WARN_DEPRECATED,
5246                 "Using an array as a reference is deprecated");
5247     }
5248     return newUNOP(OP_RV2AV, 0, scalar(o));
5249 }
5250
5251 OP *
5252 Perl_newGVREF(pTHX_ I32 type, OP *o)
5253 {
5254     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5255         return newUNOP(OP_NULL, 0, o);
5256     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5257 }
5258
5259 OP *
5260 Perl_newHVREF(pTHX_ OP *o)
5261 {
5262     if (o->op_type == OP_PADANY) {
5263         o->op_type = OP_PADHV;
5264         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5265         return o;
5266     }
5267     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5268                 && ckWARN(WARN_DEPRECATED)) {
5269         Perl_warner(aTHX_ WARN_DEPRECATED,
5270                 "Using a hash as a reference is deprecated");
5271     }
5272     return newUNOP(OP_RV2HV, 0, scalar(o));
5273 }
5274
5275 OP *
5276 Perl_oopsCV(pTHX_ OP *o)
5277 {
5278     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5279     /* STUB */
5280     return o;
5281 }
5282
5283 OP *
5284 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5285 {
5286     return newUNOP(OP_RV2CV, flags, scalar(o));
5287 }
5288
5289 OP *
5290 Perl_newSVREF(pTHX_ OP *o)
5291 {
5292     if (o->op_type == OP_PADANY) {
5293         o->op_type = OP_PADSV;
5294         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5295         return o;
5296     }
5297     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5298         o->op_flags |= OPpDONE_SVREF;
5299         return o;
5300     }
5301     return newUNOP(OP_RV2SV, 0, scalar(o));
5302 }
5303
5304 /* Check routines. */
5305
5306 OP *
5307 Perl_ck_anoncode(pTHX_ OP *o)
5308 {
5309     PADOFFSET ix;
5310     SV* name;
5311
5312     name = NEWSV(1106,0);
5313     sv_upgrade(name, SVt_PVNV);
5314     sv_setpvn(name, "&", 1);
5315     SvIVX(name) = -1;
5316     SvNVX(name) = 1;
5317     ix = pad_alloc(o->op_type, SVs_PADMY);
5318     av_store(PL_comppad_name, ix, name);
5319     av_store(PL_comppad, ix, cSVOPo->op_sv);
5320     SvPADMY_on(cSVOPo->op_sv);
5321     cSVOPo->op_sv = Nullsv;
5322     cSVOPo->op_targ = ix;
5323     return o;
5324 }
5325
5326 OP *
5327 Perl_ck_bitop(pTHX_ OP *o)
5328 {
5329     o->op_private = PL_hints;
5330     return o;
5331 }
5332
5333 OP *
5334 Perl_ck_concat(pTHX_ OP *o)
5335 {
5336     if (cUNOPo->op_first->op_type == OP_CONCAT)
5337         o->op_flags |= OPf_STACKED;
5338     return o;
5339 }
5340
5341 OP *
5342 Perl_ck_spair(pTHX_ OP *o)
5343 {
5344     if (o->op_flags & OPf_KIDS) {
5345         OP* newop;
5346         OP* kid;
5347         OPCODE type = o->op_type;
5348         o = modkids(ck_fun(o), type);
5349         kid = cUNOPo->op_first;
5350         newop = kUNOP->op_first->op_sibling;
5351         if (newop &&
5352             (newop->op_sibling ||
5353              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5354              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5355              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5356
5357             return o;
5358         }
5359         op_free(kUNOP->op_first);
5360         kUNOP->op_first = newop;
5361     }
5362     o->op_ppaddr = PL_ppaddr[++o->op_type];
5363     return ck_fun(o);
5364 }
5365
5366 OP *
5367 Perl_ck_delete(pTHX_ OP *o)
5368 {
5369     o = ck_fun(o);
5370     o->op_private = 0;
5371     if (o->op_flags & OPf_KIDS) {
5372         OP *kid = cUNOPo->op_first;
5373         switch (kid->op_type) {
5374         case OP_ASLICE:
5375             o->op_flags |= OPf_SPECIAL;
5376             /* FALL THROUGH */
5377         case OP_HSLICE:
5378             o->op_private |= OPpSLICE;
5379             break;
5380         case OP_AELEM:
5381             o->op_flags |= OPf_SPECIAL;
5382             /* FALL THROUGH */
5383         case OP_HELEM:
5384             break;
5385         default:
5386             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5387                   PL_op_desc[o->op_type]);
5388         }
5389         op_null(kid);
5390     }
5391     return o;
5392 }
5393
5394 OP *
5395 Perl_ck_eof(pTHX_ OP *o)
5396 {
5397     I32 type = o->op_type;
5398
5399     if (o->op_flags & OPf_KIDS) {
5400         if (cLISTOPo->op_first->op_type == OP_STUB) {
5401             op_free(o);
5402             o = newUNOP(type, OPf_SPECIAL,
5403                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5404         }
5405         return ck_fun(o);
5406     }
5407     return o;
5408 }
5409
5410 OP *
5411 Perl_ck_eval(pTHX_ OP *o)
5412 {
5413     PL_hints |= HINT_BLOCK_SCOPE;
5414     if (o->op_flags & OPf_KIDS) {
5415         SVOP *kid = (SVOP*)cUNOPo->op_first;
5416
5417         if (!kid) {
5418             o->op_flags &= ~OPf_KIDS;
5419             op_null(o);
5420         }
5421         else if (kid->op_type == OP_LINESEQ) {
5422             LOGOP *enter;
5423
5424             kid->op_next = o->op_next;
5425             cUNOPo->op_first = 0;
5426             op_free(o);
5427
5428             NewOp(1101, enter, 1, LOGOP);
5429             enter->op_type = OP_ENTERTRY;
5430             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5431             enter->op_private = 0;
5432
5433             /* establish postfix order */
5434             enter->op_next = (OP*)enter;
5435
5436             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5437             o->op_type = OP_LEAVETRY;
5438             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5439             enter->op_other = o;
5440             return o;
5441         }
5442         else
5443             scalar((OP*)kid);
5444     }
5445     else {
5446         op_free(o);
5447         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5448     }
5449     o->op_targ = (PADOFFSET)PL_hints;
5450     return o;
5451 }
5452
5453 OP *
5454 Perl_ck_exit(pTHX_ OP *o)
5455 {
5456 #ifdef VMS
5457     HV *table = GvHV(PL_hintgv);
5458     if (table) {
5459        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5460        if (svp && *svp && SvTRUE(*svp))
5461            o->op_private |= OPpEXIT_VMSISH;
5462     }
5463 #endif
5464     return ck_fun(o);
5465 }
5466
5467 OP *
5468 Perl_ck_exec(pTHX_ OP *o)
5469 {
5470     OP *kid;
5471     if (o->op_flags & OPf_STACKED) {
5472         o = ck_fun(o);
5473         kid = cUNOPo->op_first->op_sibling;
5474         if (kid->op_type == OP_RV2GV)
5475             op_null(kid);
5476     }
5477     else
5478         o = listkids(o);
5479     return o;
5480 }
5481
5482 OP *
5483 Perl_ck_exists(pTHX_ OP *o)
5484 {
5485     o = ck_fun(o);
5486     if (o->op_flags & OPf_KIDS) {
5487         OP *kid = cUNOPo->op_first;
5488         if (kid->op_type == OP_ENTERSUB) {
5489             (void) ref(kid, o->op_type);
5490             if (kid->op_type != OP_RV2CV && !PL_error_count)
5491                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5492                            PL_op_desc[o->op_type]);
5493             o->op_private |= OPpEXISTS_SUB;
5494         }
5495         else if (kid->op_type == OP_AELEM)
5496             o->op_flags |= OPf_SPECIAL;
5497         else if (kid->op_type != OP_HELEM)
5498             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5499                        PL_op_desc[o->op_type]);
5500         op_null(kid);
5501     }
5502     return o;
5503 }
5504
5505 #if 0
5506 OP *
5507 Perl_ck_gvconst(pTHX_ register OP *o)
5508 {
5509     o = fold_constants(o);
5510     if (o->op_type == OP_CONST)
5511         o->op_type = OP_GV;
5512     return o;
5513 }
5514 #endif
5515
5516 OP *
5517 Perl_ck_rvconst(pTHX_ register OP *o)
5518 {
5519     SVOP *kid = (SVOP*)cUNOPo->op_first;
5520
5521     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5522     if (kid->op_type == OP_CONST) {
5523         char *name;
5524         int iscv;
5525         GV *gv;
5526         SV *kidsv = kid->op_sv;
5527         STRLEN n_a;
5528
5529         /* Is it a constant from cv_const_sv()? */
5530         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5531             SV *rsv = SvRV(kidsv);
5532             int svtype = SvTYPE(rsv);
5533             char *badtype = Nullch;
5534
5535             switch (o->op_type) {
5536             case OP_RV2SV:
5537                 if (svtype > SVt_PVMG)
5538                     badtype = "a SCALAR";
5539                 break;
5540             case OP_RV2AV:
5541                 if (svtype != SVt_PVAV)
5542                     badtype = "an ARRAY";
5543                 break;
5544             case OP_RV2HV:
5545                 if (svtype != SVt_PVHV) {
5546                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5547                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5548                         if (ksv && SvROK(*ksv)
5549                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5550                         {
5551                                 break;
5552                         }
5553                     }
5554                     badtype = "a HASH";
5555                 }
5556                 break;
5557             case OP_RV2CV:
5558                 if (svtype != SVt_PVCV)
5559                     badtype = "a CODE";
5560                 break;
5561             }
5562             if (badtype)
5563                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5564             return o;
5565         }
5566         name = SvPV(kidsv, n_a);
5567         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5568             char *badthing = Nullch;
5569             switch (o->op_type) {
5570             case OP_RV2SV:
5571                 badthing = "a SCALAR";
5572                 break;
5573             case OP_RV2AV:
5574                 badthing = "an ARRAY";
5575                 break;
5576             case OP_RV2HV:
5577                 badthing = "a HASH";
5578                 break;
5579             }
5580             if (badthing)
5581                 Perl_croak(aTHX_
5582           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5583                       name, badthing);
5584         }
5585         /*
5586          * This is a little tricky.  We only want to add the symbol if we
5587          * didn't add it in the lexer.  Otherwise we get duplicate strict
5588          * warnings.  But if we didn't add it in the lexer, we must at
5589          * least pretend like we wanted to add it even if it existed before,
5590          * or we get possible typo warnings.  OPpCONST_ENTERED says
5591          * whether the lexer already added THIS instance of this symbol.
5592          */
5593         iscv = (o->op_type == OP_RV2CV) * 2;
5594         do {
5595             gv = gv_fetchpv(name,
5596                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5597                 iscv
5598                     ? SVt_PVCV
5599                     : o->op_type == OP_RV2SV
5600                         ? SVt_PV
5601                         : o->op_type == OP_RV2AV
5602                             ? SVt_PVAV
5603                             : o->op_type == OP_RV2HV
5604                                 ? SVt_PVHV
5605                                 : SVt_PVGV);
5606         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5607         if (gv) {
5608             kid->op_type = OP_GV;
5609             SvREFCNT_dec(kid->op_sv);
5610 #ifdef USE_ITHREADS
5611             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5612             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5613             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5614             GvIN_PAD_on(gv);
5615             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5616 #else
5617             kid->op_sv = SvREFCNT_inc(gv);
5618 #endif
5619             kid->op_private = 0;
5620             kid->op_ppaddr = PL_ppaddr[OP_GV];
5621         }
5622     }
5623     return o;
5624 }
5625
5626 OP *
5627 Perl_ck_ftst(pTHX_ OP *o)
5628 {
5629     I32 type = o->op_type;
5630
5631     if (o->op_flags & OPf_REF) {
5632         /* nothing */
5633     }
5634     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5635         SVOP *kid = (SVOP*)cUNOPo->op_first;
5636
5637         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5638             STRLEN n_a;
5639             OP *newop = newGVOP(type, OPf_REF,
5640                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5641             op_free(o);
5642             o = newop;
5643         }
5644     }
5645     else {
5646         op_free(o);
5647         if (type == OP_FTTTY)
5648            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5649                                 SVt_PVIO));
5650         else
5651             o = newUNOP(type, 0, newDEFSVOP());
5652     }
5653     return o;
5654 }
5655
5656 OP *
5657 Perl_ck_fun(pTHX_ OP *o)
5658 {
5659     register OP *kid;
5660     OP **tokid;
5661     OP *sibl;
5662     I32 numargs = 0;
5663     int type = o->op_type;
5664     register I32 oa = PL_opargs[type] >> OASHIFT;
5665
5666     if (o->op_flags & OPf_STACKED) {
5667         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5668             oa &= ~OA_OPTIONAL;
5669         else
5670             return no_fh_allowed(o);
5671     }
5672
5673     if (o->op_flags & OPf_KIDS) {
5674         STRLEN n_a;
5675         tokid = &cLISTOPo->op_first;
5676         kid = cLISTOPo->op_first;
5677         if (kid->op_type == OP_PUSHMARK ||
5678             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5679         {
5680             tokid = &kid->op_sibling;
5681             kid = kid->op_sibling;
5682         }
5683         if (!kid && PL_opargs[type] & OA_DEFGV)
5684             *tokid = kid = newDEFSVOP();
5685
5686         while (oa && kid) {
5687             numargs++;
5688             sibl = kid->op_sibling;
5689             switch (oa & 7) {
5690             case OA_SCALAR:
5691                 /* list seen where single (scalar) arg expected? */
5692                 if (numargs == 1 && !(oa >> 4)
5693                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5694                 {
5695                     return too_many_arguments(o,PL_op_desc[type]);
5696                 }
5697                 scalar(kid);
5698                 break;
5699             case OA_LIST:
5700                 if (oa < 16) {
5701                     kid = 0;
5702                     continue;
5703                 }
5704                 else
5705                     list(kid);
5706                 break;
5707             case OA_AVREF:
5708                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5709                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5710                     Perl_warner(aTHX_ WARN_SYNTAX,
5711                         "Useless use of %s with no values",
5712                         PL_op_desc[type]);
5713
5714                 if (kid->op_type == OP_CONST &&
5715                     (kid->op_private & OPpCONST_BARE))
5716                 {
5717                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5718                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5719                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5720                     if (ckWARN(WARN_DEPRECATED))
5721                         Perl_warner(aTHX_ WARN_DEPRECATED,
5722                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5723                             name, (IV)numargs, PL_op_desc[type]);
5724                     op_free(kid);
5725                     kid = newop;
5726                     kid->op_sibling = sibl;
5727                     *tokid = kid;
5728                 }
5729                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5730                     bad_type(numargs, "array", PL_op_desc[type], kid);
5731                 mod(kid, type);
5732                 break;
5733             case OA_HVREF:
5734                 if (kid->op_type == OP_CONST &&
5735                     (kid->op_private & OPpCONST_BARE))
5736                 {
5737                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5738                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5739                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5740                     if (ckWARN(WARN_DEPRECATED))
5741                         Perl_warner(aTHX_ WARN_DEPRECATED,
5742                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5743                             name, (IV)numargs, PL_op_desc[type]);
5744                     op_free(kid);
5745                     kid = newop;
5746                     kid->op_sibling = sibl;
5747                     *tokid = kid;
5748                 }
5749                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5750                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5751                 mod(kid, type);
5752                 break;
5753             case OA_CVREF:
5754                 {
5755                     OP *newop = newUNOP(OP_NULL, 0, kid);
5756                     kid->op_sibling = 0;
5757                     linklist(kid);
5758                     newop->op_next = newop;
5759                     kid = newop;
5760                     kid->op_sibling = sibl;
5761                     *tokid = kid;
5762                 }
5763                 break;
5764             case OA_FILEREF:
5765                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5766                     if (kid->op_type == OP_CONST &&
5767                         (kid->op_private & OPpCONST_BARE))
5768                     {
5769                         OP *newop = newGVOP(OP_GV, 0,
5770                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5771                                         SVt_PVIO) );
5772                         op_free(kid);
5773                         kid = newop;
5774                     }
5775                     else if (kid->op_type == OP_READLINE) {
5776                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5777                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5778                     }
5779                     else {
5780                         I32 flags = OPf_SPECIAL;
5781                         I32 priv = 0;
5782                         PADOFFSET targ = 0;
5783
5784                         /* is this op a FH constructor? */
5785                         if (is_handle_constructor(o,numargs)) {
5786                             char *name = Nullch;
5787                             STRLEN len;
5788
5789                             flags = 0;
5790                             /* Set a flag to tell rv2gv to vivify
5791                              * need to "prove" flag does not mean something
5792                              * else already - NI-S 1999/05/07
5793                              */
5794                             priv = OPpDEREF;
5795                             if (kid->op_type == OP_PADSV) {
5796                                 SV **namep = av_fetch(PL_comppad_name,
5797                                                       kid->op_targ, 4);
5798                                 if (namep && *namep)
5799                                     name = SvPV(*namep, len);
5800                             }
5801                             else if (kid->op_type == OP_RV2SV
5802                                      && kUNOP->op_first->op_type == OP_GV)
5803                             {
5804                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5805                                 name = GvNAME(gv);
5806                                 len = GvNAMELEN(gv);
5807                             }
5808                             else if (kid->op_type == OP_AELEM
5809                                      || kid->op_type == OP_HELEM)
5810                             {
5811                                 name = "__ANONIO__";
5812                                 len = 10;
5813                                 mod(kid,type);
5814                             }
5815                             if (name) {
5816                                 SV *namesv;
5817                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5818                                 namesv = PL_curpad[targ];
5819                                 (void)SvUPGRADE(namesv, SVt_PV);
5820                                 if (*name != '$')
5821                                     sv_setpvn(namesv, "$", 1);
5822                                 sv_catpvn(namesv, name, len);
5823                             }
5824                         }
5825                         kid->op_sibling = 0;
5826                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5827                         kid->op_targ = targ;
5828                         kid->op_private |= priv;
5829                     }
5830                     kid->op_sibling = sibl;
5831                     *tokid = kid;
5832                 }
5833                 scalar(kid);
5834                 break;
5835             case OA_SCALARREF:
5836                 mod(scalar(kid), type);
5837                 break;
5838             }
5839             oa >>= 4;
5840             tokid = &kid->op_sibling;
5841             kid = kid->op_sibling;
5842         }
5843         o->op_private |= numargs;
5844         if (kid)
5845             return too_many_arguments(o,PL_op_desc[o->op_type]);
5846         listkids(o);
5847     }
5848     else if (PL_opargs[type] & OA_DEFGV) {
5849         op_free(o);
5850         return newUNOP(type, 0, newDEFSVOP());
5851     }
5852
5853     if (oa) {
5854         while (oa & OA_OPTIONAL)
5855             oa >>= 4;
5856         if (oa && oa != OA_LIST)
5857             return too_few_arguments(o,PL_op_desc[o->op_type]);
5858     }
5859     return o;
5860 }
5861
5862 OP *
5863 Perl_ck_glob(pTHX_ OP *o)
5864 {
5865     GV *gv;
5866
5867     o = ck_fun(o);
5868     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5869         append_elem(OP_GLOB, o, newDEFSVOP());
5870
5871     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5872         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5873
5874 #if !defined(PERL_EXTERNAL_GLOB)
5875     /* XXX this can be tightened up and made more failsafe. */
5876     if (!gv) {
5877         GV *glob_gv;
5878         ENTER;
5879         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5880                          Nullsv, Nullsv);
5881         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5882         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5883         GvCV(gv) = GvCV(glob_gv);
5884         SvREFCNT_inc((SV*)GvCV(gv));
5885         GvIMPORTED_CV_on(gv);
5886         LEAVE;
5887     }
5888 #endif /* PERL_EXTERNAL_GLOB */
5889
5890     if (gv && GvIMPORTED_CV(gv)) {
5891         append_elem(OP_GLOB, o,
5892                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5893         o->op_type = OP_LIST;
5894         o->op_ppaddr = PL_ppaddr[OP_LIST];
5895         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5896         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5897         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5898                     append_elem(OP_LIST, o,
5899                                 scalar(newUNOP(OP_RV2CV, 0,
5900                                                newGVOP(OP_GV, 0, gv)))));
5901         o = newUNOP(OP_NULL, 0, ck_subr(o));
5902         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5903         return o;
5904     }
5905     gv = newGVgen("main");
5906     gv_IOadd(gv);
5907     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5908     scalarkids(o);
5909     return o;
5910 }
5911
5912 OP *
5913 Perl_ck_grep(pTHX_ OP *o)
5914 {
5915     LOGOP *gwop;
5916     OP *kid;
5917     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5918
5919     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5920     NewOp(1101, gwop, 1, LOGOP);
5921
5922     if (o->op_flags & OPf_STACKED) {
5923         OP* k;
5924         o = ck_sort(o);
5925         kid = cLISTOPo->op_first->op_sibling;
5926         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5927             kid = k;
5928         }
5929         kid->op_next = (OP*)gwop;
5930         o->op_flags &= ~OPf_STACKED;
5931     }
5932     kid = cLISTOPo->op_first->op_sibling;
5933     if (type == OP_MAPWHILE)
5934         list(kid);
5935     else
5936         scalar(kid);
5937     o = ck_fun(o);
5938     if (PL_error_count)
5939         return o;
5940     kid = cLISTOPo->op_first->op_sibling;
5941     if (kid->op_type != OP_NULL)
5942         Perl_croak(aTHX_ "panic: ck_grep");
5943     kid = kUNOP->op_first;
5944
5945     gwop->op_type = type;
5946     gwop->op_ppaddr = PL_ppaddr[type];
5947     gwop->op_first = listkids(o);
5948     gwop->op_flags |= OPf_KIDS;
5949     gwop->op_private = 1;
5950     gwop->op_other = LINKLIST(kid);
5951     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5952     kid->op_next = (OP*)gwop;
5953
5954     kid = cLISTOPo->op_first->op_sibling;
5955     if (!kid || !kid->op_sibling)
5956         return too_few_arguments(o,PL_op_desc[o->op_type]);
5957     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5958         mod(kid, OP_GREPSTART);
5959
5960     return (OP*)gwop;
5961 }
5962
5963 OP *
5964 Perl_ck_index(pTHX_ OP *o)
5965 {
5966     if (o->op_flags & OPf_KIDS) {
5967         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5968         if (kid)
5969             kid = kid->op_sibling;                      /* get past "big" */
5970         if (kid && kid->op_type == OP_CONST)
5971             fbm_compile(((SVOP*)kid)->op_sv, 0);
5972     }
5973     return ck_fun(o);
5974 }
5975
5976 OP *
5977 Perl_ck_lengthconst(pTHX_ OP *o)
5978 {
5979     /* XXX length optimization goes here */
5980     return ck_fun(o);
5981 }
5982
5983 OP *
5984 Perl_ck_lfun(pTHX_ OP *o)
5985 {
5986     OPCODE type = o->op_type;
5987     return modkids(ck_fun(o), type);
5988 }
5989
5990 OP *
5991 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5992 {
5993     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5994         switch (cUNOPo->op_first->op_type) {
5995         case OP_RV2AV:
5996             /* This is needed for
5997                if (defined %stash::)
5998                to work.   Do not break Tk.
5999                */
6000             break;                      /* Globals via GV can be undef */
6001         case OP_PADAV:
6002         case OP_AASSIGN:                /* Is this a good idea? */
6003             Perl_warner(aTHX_ WARN_DEPRECATED,
6004                         "defined(@array) is deprecated");
6005             Perl_warner(aTHX_ WARN_DEPRECATED,
6006                         "\t(Maybe you should just omit the defined()?)\n");
6007         break;
6008         case OP_RV2HV:
6009             /* This is needed for
6010                if (defined %stash::)
6011                to work.   Do not break Tk.
6012                */
6013             break;                      /* Globals via GV can be undef */
6014         case OP_PADHV:
6015             Perl_warner(aTHX_ WARN_DEPRECATED,
6016                         "defined(%%hash) is deprecated");
6017             Perl_warner(aTHX_ WARN_DEPRECATED,
6018                         "\t(Maybe you should just omit the defined()?)\n");
6019             break;
6020         default:
6021             /* no warning */
6022             break;
6023         }
6024     }
6025     return ck_rfun(o);
6026 }
6027
6028 OP *
6029 Perl_ck_rfun(pTHX_ OP *o)
6030 {
6031     OPCODE type = o->op_type;
6032     return refkids(ck_fun(o), type);
6033 }
6034
6035 OP *
6036 Perl_ck_listiob(pTHX_ OP *o)
6037 {
6038     register OP *kid;
6039
6040     kid = cLISTOPo->op_first;
6041     if (!kid) {
6042         o = force_list(o);
6043         kid = cLISTOPo->op_first;
6044     }
6045     if (kid->op_type == OP_PUSHMARK)
6046         kid = kid->op_sibling;
6047     if (kid && o->op_flags & OPf_STACKED)
6048         kid = kid->op_sibling;
6049     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6050         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6051             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6052             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6053             cLISTOPo->op_first->op_sibling = kid;
6054             cLISTOPo->op_last = kid;
6055             kid = kid->op_sibling;
6056         }
6057     }
6058
6059     if (!kid)
6060         append_elem(o->op_type, o, newDEFSVOP());
6061
6062     return listkids(o);
6063 }
6064
6065 OP *
6066 Perl_ck_sassign(pTHX_ OP *o)
6067 {
6068     OP *kid = cLISTOPo->op_first;
6069     /* has a disposable target? */
6070     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6071         && !(kid->op_flags & OPf_STACKED)
6072         /* Cannot steal the second time! */
6073         && !(kid->op_private & OPpTARGET_MY))
6074     {
6075         OP *kkid = kid->op_sibling;
6076
6077         /* Can just relocate the target. */
6078         if (kkid && kkid->op_type == OP_PADSV
6079             && !(kkid->op_private & OPpLVAL_INTRO))
6080         {
6081             kid->op_targ = kkid->op_targ;
6082             kkid->op_targ = 0;
6083             /* Now we do not need PADSV and SASSIGN. */
6084             kid->op_sibling = o->op_sibling;    /* NULL */
6085             cLISTOPo->op_first = NULL;
6086             op_free(o);
6087             op_free(kkid);
6088             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6089             return kid;
6090         }
6091     }
6092     return o;
6093 }
6094
6095 OP *
6096 Perl_ck_match(pTHX_ OP *o)
6097 {
6098     o->op_private |= OPpRUNTIME;
6099     return o;
6100 }
6101
6102 OP *
6103 Perl_ck_method(pTHX_ OP *o)
6104 {
6105     OP *kid = cUNOPo->op_first;
6106     if (kid->op_type == OP_CONST) {
6107         SV* sv = kSVOP->op_sv;
6108         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6109             OP *cmop;
6110             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6111                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6112             }
6113             else {
6114                 kSVOP->op_sv = Nullsv;
6115             }
6116             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6117             op_free(o);
6118             return cmop;
6119         }
6120     }
6121     return o;
6122 }
6123
6124 OP *
6125 Perl_ck_null(pTHX_ OP *o)
6126 {
6127     return o;
6128 }
6129
6130 OP *
6131 Perl_ck_open(pTHX_ OP *o)
6132 {
6133     HV *table = GvHV(PL_hintgv);
6134     if (table) {
6135         SV **svp;
6136         I32 mode;
6137         svp = hv_fetch(table, "open_IN", 7, FALSE);
6138         if (svp && *svp) {
6139             mode = mode_from_discipline(*svp);
6140             if (mode & O_BINARY)
6141                 o->op_private |= OPpOPEN_IN_RAW;
6142             else if (mode & O_TEXT)
6143                 o->op_private |= OPpOPEN_IN_CRLF;
6144         }
6145
6146         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6147         if (svp && *svp) {
6148             mode = mode_from_discipline(*svp);
6149             if (mode & O_BINARY)
6150                 o->op_private |= OPpOPEN_OUT_RAW;
6151             else if (mode & O_TEXT)
6152                 o->op_private |= OPpOPEN_OUT_CRLF;
6153         }
6154     }
6155     if (o->op_type == OP_BACKTICK)
6156         return o;
6157     return ck_fun(o);
6158 }
6159
6160 OP *
6161 Perl_ck_repeat(pTHX_ OP *o)
6162 {
6163     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6164         o->op_private |= OPpREPEAT_DOLIST;
6165         cBINOPo->op_first = force_list(cBINOPo->op_first);
6166     }
6167     else
6168         scalar(o);
6169     return o;
6170 }
6171
6172 OP *
6173 Perl_ck_require(pTHX_ OP *o)
6174 {
6175     GV* gv;
6176
6177     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6178         SVOP *kid = (SVOP*)cUNOPo->op_first;
6179
6180         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6181             char *s;
6182             for (s = SvPVX(kid->op_sv); *s; s++) {
6183                 if (*s == ':' && s[1] == ':') {
6184                     *s = '/';
6185                     Move(s+2, s+1, strlen(s+2)+1, char);
6186                     --SvCUR(kid->op_sv);
6187                 }
6188             }
6189             if (SvREADONLY(kid->op_sv)) {
6190                 SvREADONLY_off(kid->op_sv);
6191                 sv_catpvn(kid->op_sv, ".pm", 3);
6192                 SvREADONLY_on(kid->op_sv);
6193             }
6194             else
6195                 sv_catpvn(kid->op_sv, ".pm", 3);
6196         }
6197     }
6198
6199     /* handle override, if any */
6200     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6201     if (!(gv && GvIMPORTED_CV(gv)))
6202         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6203
6204     if (gv && GvIMPORTED_CV(gv)) {
6205         OP *kid = cUNOPo->op_first;
6206         cUNOPo->op_first = 0;
6207         op_free(o);
6208         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6209                                append_elem(OP_LIST, kid,
6210                                            scalar(newUNOP(OP_RV2CV, 0,
6211                                                           newGVOP(OP_GV, 0,
6212                                                                   gv))))));
6213     }
6214
6215     return ck_fun(o);
6216 }
6217
6218 OP *
6219 Perl_ck_return(pTHX_ OP *o)
6220 {
6221     OP *kid;
6222     if (CvLVALUE(PL_compcv)) {
6223         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6224             mod(kid, OP_LEAVESUBLV);
6225     }
6226     return o;
6227 }
6228
6229 #if 0
6230 OP *
6231 Perl_ck_retarget(pTHX_ OP *o)
6232 {
6233     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6234     /* STUB */
6235     return o;
6236 }
6237 #endif
6238
6239 OP *
6240 Perl_ck_select(pTHX_ OP *o)
6241 {
6242     OP* kid;
6243     if (o->op_flags & OPf_KIDS) {
6244         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6245         if (kid && kid->op_sibling) {
6246             o->op_type = OP_SSELECT;
6247             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6248             o = ck_fun(o);
6249             return fold_constants(o);
6250         }
6251     }
6252     o = ck_fun(o);
6253     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6254     if (kid && kid->op_type == OP_RV2GV)
6255         kid->op_private &= ~HINT_STRICT_REFS;
6256     return o;
6257 }
6258
6259 OP *
6260 Perl_ck_shift(pTHX_ OP *o)
6261 {
6262     I32 type = o->op_type;
6263
6264     if (!(o->op_flags & OPf_KIDS)) {
6265         OP *argop;
6266
6267         op_free(o);
6268 #ifdef USE_THREADS
6269         if (!CvUNIQUE(PL_compcv)) {
6270             argop = newOP(OP_PADAV, OPf_REF);
6271             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6272         }
6273         else {
6274             argop = newUNOP(OP_RV2AV, 0,
6275                 scalar(newGVOP(OP_GV, 0,
6276                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6277         }
6278 #else
6279         argop = newUNOP(OP_RV2AV, 0,
6280             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6281                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6282 #endif /* USE_THREADS */
6283         return newUNOP(type, 0, scalar(argop));
6284     }
6285     return scalar(modkids(ck_fun(o), type));
6286 }
6287
6288 OP *
6289 Perl_ck_sort(pTHX_ OP *o)
6290 {
6291     OP *firstkid;
6292
6293     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6294         simplify_sort(o);
6295     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6296     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6297         OP *k = NULL;
6298         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6299
6300         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6301             linklist(kid);
6302             if (kid->op_type == OP_SCOPE) {
6303                 k = kid->op_next;
6304                 kid->op_next = 0;
6305             }
6306             else if (kid->op_type == OP_LEAVE) {
6307                 if (o->op_type == OP_SORT) {
6308                     op_null(kid);                       /* wipe out leave */
6309                     kid->op_next = kid;
6310
6311                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6312                         if (k->op_next == kid)
6313                             k->op_next = 0;
6314                         /* don't descend into loops */
6315                         else if (k->op_type == OP_ENTERLOOP
6316                                  || k->op_type == OP_ENTERITER)
6317                         {
6318                             k = cLOOPx(k)->op_lastop;
6319                         }
6320                     }
6321                 }
6322                 else
6323                     kid->op_next = 0;           /* just disconnect the leave */
6324                 k = kLISTOP->op_first;
6325             }
6326             peep(k);
6327
6328             kid = firstkid;
6329             if (o->op_type == OP_SORT) {
6330                 /* provide scalar context for comparison function/block */
6331                 kid = scalar(kid);
6332                 kid->op_next = kid;
6333             }
6334             else
6335                 kid->op_next = k;
6336             o->op_flags |= OPf_SPECIAL;
6337         }
6338         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6339             op_null(firstkid);
6340
6341         firstkid = firstkid->op_sibling;
6342     }
6343
6344     /* provide list context for arguments */
6345     if (o->op_type == OP_SORT)
6346         list(firstkid);
6347
6348     return o;
6349 }
6350
6351 STATIC void
6352 S_simplify_sort(pTHX_ OP *o)
6353 {
6354     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6355     OP *k;
6356     int reversed;
6357     GV *gv;
6358     if (!(o->op_flags & OPf_STACKED))
6359         return;
6360     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6361     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6362     kid = kUNOP->op_first;                              /* get past null */
6363     if (kid->op_type != OP_SCOPE)
6364         return;
6365     kid = kLISTOP->op_last;                             /* get past scope */
6366     switch(kid->op_type) {
6367         case OP_NCMP:
6368         case OP_I_NCMP:
6369         case OP_SCMP:
6370             break;
6371         default:
6372             return;
6373     }
6374     k = kid;                                            /* remember this node*/
6375     if (kBINOP->op_first->op_type != OP_RV2SV)
6376         return;
6377     kid = kBINOP->op_first;                             /* get past cmp */
6378     if (kUNOP->op_first->op_type != OP_GV)
6379         return;
6380     kid = kUNOP->op_first;                              /* get past rv2sv */
6381     gv = kGVOP_gv;
6382     if (GvSTASH(gv) != PL_curstash)
6383         return;
6384     if (strEQ(GvNAME(gv), "a"))
6385         reversed = 0;
6386     else if (strEQ(GvNAME(gv), "b"))
6387         reversed = 1;
6388     else
6389         return;
6390     kid = k;                                            /* back to cmp */
6391     if (kBINOP->op_last->op_type != OP_RV2SV)
6392         return;
6393     kid = kBINOP->op_last;                              /* down to 2nd arg */
6394     if (kUNOP->op_first->op_type != OP_GV)
6395         return;
6396     kid = kUNOP->op_first;                              /* get past rv2sv */
6397     gv = kGVOP_gv;
6398     if (GvSTASH(gv) != PL_curstash
6399         || ( reversed
6400             ? strNE(GvNAME(gv), "a")
6401             : strNE(GvNAME(gv), "b")))
6402         return;
6403     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6404     if (reversed)
6405         o->op_private |= OPpSORT_REVERSE;
6406     if (k->op_type == OP_NCMP)
6407         o->op_private |= OPpSORT_NUMERIC;
6408     if (k->op_type == OP_I_NCMP)
6409         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6410     kid = cLISTOPo->op_first->op_sibling;
6411     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6412     op_free(kid);                                     /* then delete it */
6413 }
6414
6415 OP *
6416 Perl_ck_split(pTHX_ OP *o)
6417 {
6418     register OP *kid;
6419
6420     if (o->op_flags & OPf_STACKED)
6421         return no_fh_allowed(o);
6422
6423     kid = cLISTOPo->op_first;
6424     if (kid->op_type != OP_NULL)
6425         Perl_croak(aTHX_ "panic: ck_split");
6426     kid = kid->op_sibling;
6427     op_free(cLISTOPo->op_first);
6428     cLISTOPo->op_first = kid;
6429     if (!kid) {
6430         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6431         cLISTOPo->op_last = kid; /* There was only one element previously */
6432     }
6433
6434     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6435         OP *sibl = kid->op_sibling;
6436         kid->op_sibling = 0;
6437         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6438         if (cLISTOPo->op_first == cLISTOPo->op_last)
6439             cLISTOPo->op_last = kid;
6440         cLISTOPo->op_first = kid;
6441         kid->op_sibling = sibl;
6442     }
6443
6444     kid->op_type = OP_PUSHRE;
6445     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6446     scalar(kid);
6447
6448     if (!kid->op_sibling)
6449         append_elem(OP_SPLIT, o, newDEFSVOP());
6450
6451     kid = kid->op_sibling;
6452     scalar(kid);
6453
6454     if (!kid->op_sibling)
6455         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6456
6457     kid = kid->op_sibling;
6458     scalar(kid);
6459
6460     if (kid->op_sibling)
6461         return too_many_arguments(o,PL_op_desc[o->op_type]);
6462
6463     return o;
6464 }
6465
6466 OP *
6467 Perl_ck_join(pTHX_ OP *o)
6468 {
6469     if (ckWARN(WARN_SYNTAX)) {
6470         OP *kid = cLISTOPo->op_first->op_sibling;
6471         if (kid && kid->op_type == OP_MATCH) {
6472             char *pmstr = "STRING";
6473             if (PM_GETRE(kPMOP))
6474                 pmstr = PM_GETRE(kPMOP)->precomp;
6475             Perl_warner(aTHX_ WARN_SYNTAX,
6476                         "/%s/ should probably be written as \"%s\"",
6477                         pmstr, pmstr);
6478         }
6479     }
6480     return ck_fun(o);
6481 }
6482
6483 OP *
6484 Perl_ck_subr(pTHX_ OP *o)
6485 {
6486     OP *prev = ((cUNOPo->op_first->op_sibling)
6487              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6488     OP *o2 = prev->op_sibling;
6489     OP *cvop;
6490     char *proto = 0;
6491     CV *cv = 0;
6492     GV *namegv = 0;
6493     int optional = 0;
6494     I32 arg = 0;
6495     STRLEN n_a;
6496
6497     o->op_private |= OPpENTERSUB_HASTARG;
6498     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6499     if (cvop->op_type == OP_RV2CV) {
6500         SVOP* tmpop;
6501         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6502         op_null(cvop);          /* disable rv2cv */
6503         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6504         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6505             GV *gv = cGVOPx_gv(tmpop);
6506             cv = GvCVu(gv);
6507             if (!cv)
6508                 tmpop->op_private |= OPpEARLY_CV;
6509             else if (SvPOK(cv)) {
6510                 namegv = CvANON(cv) ? gv : CvGV(cv);
6511                 proto = SvPV((SV*)cv, n_a);
6512             }
6513         }
6514     }
6515     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6516         if (o2->op_type == OP_CONST)
6517             o2->op_private &= ~OPpCONST_STRICT;
6518         else if (o2->op_type == OP_LIST) {
6519             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6520             if (o && o->op_type == OP_CONST)
6521                 o->op_private &= ~OPpCONST_STRICT;
6522         }
6523     }
6524     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6525     if (PERLDB_SUB && PL_curstash != PL_debstash)
6526         o->op_private |= OPpENTERSUB_DB;
6527     while (o2 != cvop) {
6528         if (proto) {
6529             switch (*proto) {
6530             case '\0':
6531                 return too_many_arguments(o, gv_ename(namegv));
6532             case ';':
6533                 optional = 1;
6534                 proto++;
6535                 continue;
6536             case '$':
6537                 proto++;
6538                 arg++;
6539                 scalar(o2);
6540                 break;
6541             case '%':
6542             case '@':
6543                 list(o2);
6544                 arg++;
6545                 break;
6546             case '&':
6547                 proto++;
6548                 arg++;
6549                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6550                     bad_type(arg,
6551                         arg == 1 ? "block or sub {}" : "sub {}",
6552                         gv_ename(namegv), o2);
6553                 break;
6554             case '*':
6555                 /* '*' allows any scalar type, including bareword */
6556                 proto++;
6557                 arg++;
6558                 if (o2->op_type == OP_RV2GV)
6559                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6560                 else if (o2->op_type == OP_CONST)
6561                     o2->op_private &= ~OPpCONST_STRICT;
6562                 else if (o2->op_type == OP_ENTERSUB) {
6563                     /* accidental subroutine, revert to bareword */
6564                     OP *gvop = ((UNOP*)o2)->op_first;
6565                     if (gvop && gvop->op_type == OP_NULL) {
6566                         gvop = ((UNOP*)gvop)->op_first;
6567                         if (gvop) {
6568                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6569                                 ;
6570                             if (gvop &&
6571                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6572                                 (gvop = ((UNOP*)gvop)->op_first) &&
6573                                 gvop->op_type == OP_GV)
6574                             {
6575                                 GV *gv = cGVOPx_gv(gvop);
6576                                 OP *sibling = o2->op_sibling;
6577                                 SV *n = newSVpvn("",0);
6578                                 op_free(o2);
6579                                 gv_fullname3(n, gv, "");
6580                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6581                                     sv_chop(n, SvPVX(n)+6);
6582                                 o2 = newSVOP(OP_CONST, 0, n);
6583                                 prev->op_sibling = o2;
6584                                 o2->op_sibling = sibling;
6585                             }
6586                         }
6587                     }
6588                 }
6589                 scalar(o2);
6590                 break;
6591             case '\\':
6592                 proto++;
6593                 arg++;
6594                 switch (*proto++) {
6595                 case '*':
6596                     if (o2->op_type != OP_RV2GV)
6597                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6598                     goto wrapref;
6599                 case '&':
6600                     if (o2->op_type != OP_ENTERSUB)
6601                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6602                     goto wrapref;
6603                 case '$':
6604                     if (o2->op_type != OP_RV2SV
6605                         && o2->op_type != OP_PADSV
6606                         && o2->op_type != OP_HELEM
6607                         && o2->op_type != OP_AELEM
6608                         && o2->op_type != OP_THREADSV)
6609                     {
6610                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6611                     }
6612                     goto wrapref;
6613                 case '@':
6614                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6615                         bad_type(arg, "array", gv_ename(namegv), o2);
6616                     goto wrapref;
6617                 case '%':
6618                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6619                         bad_type(arg, "hash", gv_ename(namegv), o2);
6620                   wrapref:
6621                     {
6622                         OP* kid = o2;
6623                         OP* sib = kid->op_sibling;
6624                         kid->op_sibling = 0;
6625                         o2 = newUNOP(OP_REFGEN, 0, kid);
6626                         o2->op_sibling = sib;
6627                         prev->op_sibling = o2;
6628                     }
6629                     break;
6630                 default: goto oops;
6631                 }
6632                 break;
6633             case ' ':
6634                 proto++;
6635                 continue;
6636             default:
6637               oops:
6638                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6639                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6640             }
6641         }
6642         else
6643             list(o2);
6644         mod(o2, OP_ENTERSUB);
6645         prev = o2;
6646         o2 = o2->op_sibling;
6647     }
6648     if (proto && !optional &&
6649           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6650         return too_few_arguments(o, gv_ename(namegv));
6651     return o;
6652 }
6653
6654 OP *
6655 Perl_ck_svconst(pTHX_ OP *o)
6656 {
6657     SvREADONLY_on(cSVOPo->op_sv);
6658     return o;
6659 }
6660
6661 OP *
6662 Perl_ck_trunc(pTHX_ OP *o)
6663 {
6664     if (o->op_flags & OPf_KIDS) {
6665         SVOP *kid = (SVOP*)cUNOPo->op_first;
6666
6667         if (kid->op_type == OP_NULL)
6668             kid = (SVOP*)kid->op_sibling;
6669         if (kid && kid->op_type == OP_CONST &&
6670             (kid->op_private & OPpCONST_BARE))
6671         {
6672             o->op_flags |= OPf_SPECIAL;
6673             kid->op_private &= ~OPpCONST_STRICT;
6674         }
6675     }
6676     return ck_fun(o);
6677 }
6678
6679 OP *
6680 Perl_ck_substr(pTHX_ OP *o)
6681 {
6682     o = ck_fun(o);
6683     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6684         OP *kid = cLISTOPo->op_first;
6685
6686         if (kid->op_type == OP_NULL)
6687             kid = kid->op_sibling;
6688         if (kid)
6689             kid->op_flags |= OPf_MOD;
6690
6691     }
6692     return o;
6693 }
6694
6695 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6696
6697 void
6698 Perl_peep(pTHX_ register OP *o)
6699 {
6700     register OP* oldop = 0;
6701     STRLEN n_a;
6702
6703     if (!o || o->op_seq)
6704         return;
6705     ENTER;
6706     SAVEOP();
6707     SAVEVPTR(PL_curcop);
6708     for (; o; o = o->op_next) {
6709         if (o->op_seq)
6710             break;
6711         if (!PL_op_seqmax)
6712             PL_op_seqmax++;
6713         PL_op = o;
6714         switch (o->op_type) {
6715         case OP_SETSTATE:
6716         case OP_NEXTSTATE:
6717         case OP_DBSTATE:
6718             PL_curcop = ((COP*)o);              /* for warnings */
6719             o->op_seq = PL_op_seqmax++;
6720             break;
6721
6722         case OP_CONST:
6723             if (cSVOPo->op_private & OPpCONST_STRICT)
6724                 no_bareword_allowed(o);
6725 #ifdef USE_ITHREADS
6726             /* Relocate sv to the pad for thread safety.
6727              * Despite being a "constant", the SV is written to,
6728              * for reference counts, sv_upgrade() etc. */
6729             if (cSVOP->op_sv) {
6730                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6731                 if (SvPADTMP(cSVOPo->op_sv)) {
6732                     /* If op_sv is already a PADTMP then it is being used by
6733                      * some pad, so make a copy. */
6734                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6735                     SvREADONLY_on(PL_curpad[ix]);
6736                     SvREFCNT_dec(cSVOPo->op_sv);
6737                 }
6738                 else {
6739                     SvREFCNT_dec(PL_curpad[ix]);
6740                     SvPADTMP_on(cSVOPo->op_sv);
6741                     PL_curpad[ix] = cSVOPo->op_sv;
6742                     /* XXX I don't know how this isn't readonly already. */
6743                     SvREADONLY_on(PL_curpad[ix]);
6744                 }
6745                 cSVOPo->op_sv = Nullsv;
6746                 o->op_targ = ix;
6747             }
6748 #endif
6749             o->op_seq = PL_op_seqmax++;
6750             break;
6751
6752         case OP_CONCAT:
6753             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6754                 if (o->op_next->op_private & OPpTARGET_MY) {
6755                     if (o->op_flags & OPf_STACKED) /* chained concats */
6756                         goto ignore_optimization;
6757                     else {
6758                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6759                         o->op_targ = o->op_next->op_targ;
6760                         o->op_next->op_targ = 0;
6761                         o->op_private |= OPpTARGET_MY;
6762                     }
6763                 }
6764                 op_null(o->op_next);
6765             }
6766           ignore_optimization:
6767             o->op_seq = PL_op_seqmax++;
6768             break;
6769         case OP_STUB:
6770             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6771                 o->op_seq = PL_op_seqmax++;
6772                 break; /* Scalar stub must produce undef.  List stub is noop */
6773             }
6774             goto nothin;
6775         case OP_NULL:
6776             if (o->op_targ == OP_NEXTSTATE
6777                 || o->op_targ == OP_DBSTATE
6778                 || o->op_targ == OP_SETSTATE)
6779             {
6780                 PL_curcop = ((COP*)o);
6781             }
6782             goto nothin;
6783         case OP_SCALAR:
6784         case OP_LINESEQ:
6785         case OP_SCOPE:
6786           nothin:
6787             if (oldop && o->op_next) {
6788                 oldop->op_next = o->op_next;
6789                 continue;
6790             }
6791             o->op_seq = PL_op_seqmax++;
6792             break;
6793
6794         case OP_GV:
6795             if (o->op_next->op_type == OP_RV2SV) {
6796                 if (!(o->op_next->op_private & OPpDEREF)) {
6797                     op_null(o->op_next);
6798                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6799                                                                | OPpOUR_INTRO);
6800                     o->op_next = o->op_next->op_next;
6801                     o->op_type = OP_GVSV;
6802                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6803                 }
6804             }
6805             else if (o->op_next->op_type == OP_RV2AV) {
6806                 OP* pop = o->op_next->op_next;
6807                 IV i;
6808                 if (pop->op_type == OP_CONST &&
6809                     (PL_op = pop->op_next) &&
6810                     pop->op_next->op_type == OP_AELEM &&
6811                     !(pop->op_next->op_private &
6812                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6813                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6814                                 <= 255 &&
6815                     i >= 0)
6816                 {
6817                     GV *gv;
6818                     op_null(o->op_next);
6819                     op_null(pop->op_next);
6820                     op_null(pop);
6821                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6822                     o->op_next = pop->op_next->op_next;
6823                     o->op_type = OP_AELEMFAST;
6824                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6825                     o->op_private = (U8)i;
6826                     gv = cGVOPo_gv;
6827                     GvAVn(gv);
6828                 }
6829             }
6830             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6831                 GV *gv = cGVOPo_gv;
6832                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6833                     /* XXX could check prototype here instead of just carping */
6834                     SV *sv = sv_newmortal();
6835                     gv_efullname3(sv, gv, Nullch);
6836                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6837                                 "%s() called too early to check prototype",
6838                                 SvPV_nolen(sv));
6839                 }
6840             }
6841
6842             o->op_seq = PL_op_seqmax++;
6843             break;
6844
6845         case OP_MAPWHILE:
6846         case OP_GREPWHILE:
6847         case OP_AND:
6848         case OP_OR:
6849         case OP_ANDASSIGN:
6850         case OP_ORASSIGN:
6851         case OP_COND_EXPR:
6852         case OP_RANGE:
6853             o->op_seq = PL_op_seqmax++;
6854             while (cLOGOP->op_other->op_type == OP_NULL)
6855                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6856             peep(cLOGOP->op_other);
6857             break;
6858
6859         case OP_ENTERLOOP:
6860         case OP_ENTERITER:
6861             o->op_seq = PL_op_seqmax++;
6862             while (cLOOP->op_redoop->op_type == OP_NULL)
6863                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6864             peep(cLOOP->op_redoop);
6865             while (cLOOP->op_nextop->op_type == OP_NULL)
6866                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6867             peep(cLOOP->op_nextop);
6868             while (cLOOP->op_lastop->op_type == OP_NULL)
6869                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6870             peep(cLOOP->op_lastop);
6871             break;
6872
6873         case OP_QR:
6874         case OP_MATCH:
6875         case OP_SUBST:
6876             o->op_seq = PL_op_seqmax++;
6877             while (cPMOP->op_pmreplstart &&
6878                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6879                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6880             peep(cPMOP->op_pmreplstart);
6881             break;
6882
6883         case OP_EXEC:
6884             o->op_seq = PL_op_seqmax++;
6885             if (ckWARN(WARN_SYNTAX) && o->op_next
6886                 && o->op_next->op_type == OP_NEXTSTATE) {
6887                 if (o->op_next->op_sibling &&
6888                         o->op_next->op_sibling->op_type != OP_EXIT &&
6889                         o->op_next->op_sibling->op_type != OP_WARN &&
6890                         o->op_next->op_sibling->op_type != OP_DIE) {
6891                     line_t oldline = CopLINE(PL_curcop);
6892
6893                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6894                     Perl_warner(aTHX_ WARN_EXEC,
6895                                 "Statement unlikely to be reached");
6896                     Perl_warner(aTHX_ WARN_EXEC,
6897                                 "\t(Maybe you meant system() when you said exec()?)\n");
6898                     CopLINE_set(PL_curcop, oldline);
6899                 }
6900             }
6901             break;
6902
6903         case OP_HELEM: {
6904             UNOP *rop;
6905             SV *lexname;
6906             GV **fields;
6907             SV **svp, **indsvp, *sv;
6908             I32 ind;
6909             char *key = NULL;
6910             STRLEN keylen;
6911
6912             o->op_seq = PL_op_seqmax++;
6913
6914             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6915                 break;
6916
6917             /* Make the CONST have a shared SV */
6918             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6919             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6920                 key = SvPV(sv, keylen);
6921                 lexname = newSVpvn_share(key,
6922                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6923                                          0);
6924                 SvREFCNT_dec(sv);
6925                 *svp = lexname;
6926             }
6927
6928             if ((o->op_private & (OPpLVAL_INTRO)))
6929                 break;
6930
6931             rop = (UNOP*)((BINOP*)o)->op_first;
6932             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6933                 break;
6934             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6935             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6936                 break;
6937             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6938             if (!fields || !GvHV(*fields))
6939                 break;
6940             key = SvPV(*svp, keylen);
6941             indsvp = hv_fetch(GvHV(*fields), key,
6942                               SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6943             if (!indsvp) {
6944                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6945                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6946             }
6947             ind = SvIV(*indsvp);
6948             if (ind < 1)
6949                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6950             rop->op_type = OP_RV2AV;
6951             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6952             o->op_type = OP_AELEM;
6953             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6954             sv = newSViv(ind);
6955             if (SvREADONLY(*svp))
6956                 SvREADONLY_on(sv);
6957             SvFLAGS(sv) |= (SvFLAGS(*svp)
6958                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6959             SvREFCNT_dec(*svp);
6960             *svp = sv;
6961             break;
6962         }
6963
6964         case OP_HSLICE: {
6965             UNOP *rop;
6966             SV *lexname;
6967             GV **fields;
6968             SV **svp, **indsvp, *sv;
6969             I32 ind;
6970             char *key;
6971             STRLEN keylen;
6972             SVOP *first_key_op, *key_op;
6973
6974             o->op_seq = PL_op_seqmax++;
6975             if ((o->op_private & (OPpLVAL_INTRO))
6976                 /* I bet there's always a pushmark... */
6977                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6978                 /* hmmm, no optimization if list contains only one key. */
6979                 break;
6980             rop = (UNOP*)((LISTOP*)o)->op_last;
6981             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6982                 break;
6983             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6984             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6985                 break;
6986             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6987             if (!fields || !GvHV(*fields))
6988                 break;
6989             /* Again guessing that the pushmark can be jumped over.... */
6990             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6991                 ->op_first->op_sibling;
6992             /* Check that the key list contains only constants. */
6993             for (key_op = first_key_op; key_op;
6994                  key_op = (SVOP*)key_op->op_sibling)
6995                 if (key_op->op_type != OP_CONST)
6996                     break;
6997             if (key_op)
6998                 break;
6999             rop->op_type = OP_RV2AV;
7000             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7001             o->op_type = OP_ASLICE;
7002             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7003             for (key_op = first_key_op; key_op;
7004                  key_op = (SVOP*)key_op->op_sibling) {
7005                 svp = cSVOPx_svp(key_op);
7006                 key = SvPV(*svp, keylen);
7007                 indsvp = hv_fetch(GvHV(*fields), key,
7008                                   SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7009                 if (!indsvp) {
7010                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7011                                "in variable %s of type %s",
7012                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7013                 }
7014                 ind = SvIV(*indsvp);
7015                 if (ind < 1)
7016                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7017                 sv = newSViv(ind);
7018                 if (SvREADONLY(*svp))
7019                     SvREADONLY_on(sv);
7020                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7021                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7022                 SvREFCNT_dec(*svp);
7023                 *svp = sv;
7024             }
7025             break;
7026         }
7027
7028         default:
7029             o->op_seq = PL_op_seqmax++;
7030             break;
7031         }
7032         oldop = o;
7033     }
7034     LEAVE;
7035 }
7036
7037 #include "XSUB.h"
7038
7039 /* Efficient sub that returns a constant scalar value. */
7040 static void
7041 const_sv_xsub(pTHXo_ CV* cv)
7042 {
7043     dXSARGS;
7044     if (items != 0) {
7045 #if 0
7046         Perl_croak(aTHX_ "usage: %s::%s()",
7047                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7048 #endif
7049     }
7050     EXTEND(sp, 1);
7051     ST(0) = (SV*)XSANY.any_ptr;
7052     XSRETURN(1);
7053 }
7054