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