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