op.c

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