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