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