op.c

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