op.c

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