op.c

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