op.c

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