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;
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) && imop && SvPOK(packsv = ((SVOP*)id)->op_sv)) {
3283         /* BEGIN will free the ops, so we need to make a copy */
3284         packlen = SvCUR(packsv);
3285         packname = savepvn(SvPVX(packsv), packlen);
3286     }
3287
3288     /* Fake up the BEGIN {}, which does its thing immediately. */
3289     newATTRSUB(floor,
3290         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3291         Nullop,
3292         Nullop,
3293         append_elem(OP_LINESEQ,
3294             append_elem(OP_LINESEQ,
3295                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3296                 newSTATEOP(0, Nullch, veop)),
3297             newSTATEOP(0, Nullch, imop) ));
3298
3299     if (packname) {
3300         if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3301             Perl_warner(aTHX_ WARN_MISC,
3302                         "Package `%s' not found "
3303                         "(did you use the incorrect case?)", packname);
3304         }
3305         safefree(packname);
3306     }
3307
3308     PL_hints |= HINT_BLOCK_SCOPE;
3309     PL_copline = NOLINE;
3310     PL_expect = XSTATE;
3311 }
3312
3313 /*
3314 =for apidoc load_module
3315
3316 Loads the module whose name is pointed to by the string part of name.
3317 Note that the actual module name, not its filename, should be given.
3318 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3319 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3320 (or 0 for no flags). ver, if specified, provides version semantics
3321 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3322 arguments can be used to specify arguments to the module's import()
3323 method, similar to C<use Foo::Bar VERSION LIST>.
3324
3325 =cut */
3326
3327 void
3328 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3329 {
3330     va_list args;
3331     va_start(args, ver);
3332     vload_module(flags, name, ver, &args);
3333     va_end(args);
3334 }
3335
3336 #ifdef PERL_IMPLICIT_CONTEXT
3337 void
3338 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3339 {
3340     dTHX;
3341     va_list args;
3342     va_start(args, ver);
3343     vload_module(flags, name, ver, &args);
3344     va_end(args);
3345 }
3346 #endif
3347
3348 void
3349 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3350 {
3351     OP *modname, *veop, *imop;
3352
3353     modname = newSVOP(OP_CONST, 0, name);
3354     modname->op_private |= OPpCONST_BARE;
3355     if (ver) {
3356         veop = newSVOP(OP_CONST, 0, ver);
3357     }
3358     else
3359         veop = Nullop;
3360     if (flags & PERL_LOADMOD_NOIMPORT) {
3361         imop = sawparens(newNULLLIST());
3362     }
3363     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3364         imop = va_arg(*args, OP*);
3365     }
3366     else {
3367         SV *sv;
3368         imop = Nullop;
3369         sv = va_arg(*args, SV*);
3370         while (sv) {
3371             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3372             sv = va_arg(*args, SV*);
3373         }
3374     }
3375     {
3376         line_t ocopline = PL_copline;
3377         int oexpect = PL_expect;
3378
3379         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3380                 veop, modname, imop);
3381         PL_expect = oexpect;
3382         PL_copline = ocopline;
3383     }
3384 }
3385
3386 OP *
3387 Perl_dofile(pTHX_ OP *term)
3388 {
3389     OP *doop;
3390     GV *gv;
3391
3392     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3393     if (!(gv && GvIMPORTED_CV(gv)))
3394         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3395
3396     if (gv && GvIMPORTED_CV(gv)) {
3397         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3398                                append_elem(OP_LIST, term,
3399                                            scalar(newUNOP(OP_RV2CV, 0,
3400                                                           newGVOP(OP_GV, 0,
3401                                                                   gv))))));
3402     }
3403     else {
3404         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3405     }
3406     return doop;
3407 }
3408
3409 OP *
3410 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3411 {
3412     return newBINOP(OP_LSLICE, flags,
3413             list(force_list(subscript)),
3414             list(force_list(listval)) );
3415 }
3416
3417 STATIC I32
3418 S_list_assignment(pTHX_ register OP *o)
3419 {
3420     if (!o)
3421         return TRUE;
3422
3423     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3424         o = cUNOPo->op_first;
3425
3426     if (o->op_type == OP_COND_EXPR) {
3427         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3428         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3429
3430         if (t && f)
3431             return TRUE;
3432         if (t || f)
3433             yyerror("Assignment to both a list and a scalar");
3434         return FALSE;
3435     }
3436
3437     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3438         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3439         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3440         return TRUE;
3441
3442     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3443         return TRUE;
3444
3445     if (o->op_type == OP_RV2SV)
3446         return FALSE;
3447
3448     return FALSE;
3449 }
3450
3451 OP *
3452 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3453 {
3454     OP *o;
3455
3456     if (optype) {
3457         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3458             return newLOGOP(optype, 0,
3459                 mod(scalar(left), optype),
3460                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3461         }
3462         else {
3463             return newBINOP(optype, OPf_STACKED,
3464                 mod(scalar(left), optype), scalar(right));
3465         }
3466     }
3467
3468     if (list_assignment(left)) {
3469         OP *curop;
3470
3471         PL_modcount = 0;
3472         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3473         left = mod(left, OP_AASSIGN);
3474         if (PL_eval_start)
3475             PL_eval_start = 0;
3476         else {
3477             op_free(left);
3478             op_free(right);
3479             return Nullop;
3480         }
3481         curop = list(force_list(left));
3482         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3483         o->op_private = 0 | (flags >> 8);
3484         for (curop = ((LISTOP*)curop)->op_first;
3485              curop; curop = curop->op_sibling)
3486         {
3487             if (curop->op_type == OP_RV2HV &&
3488                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3489                 o->op_private |= OPpASSIGN_HASH;
3490                 break;
3491             }
3492         }
3493         if (!(left->op_private & OPpLVAL_INTRO)) {
3494             OP *lastop = o;
3495             PL_generation++;
3496             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3497                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3498                     if (curop->op_type == OP_GV) {
3499                         GV *gv = cGVOPx_gv(curop);
3500                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3501                             break;
3502                         SvCUR(gv) = PL_generation;
3503                     }
3504                     else if (curop->op_type == OP_PADSV ||
3505                              curop->op_type == OP_PADAV ||
3506                              curop->op_type == OP_PADHV ||
3507                              curop->op_type == OP_PADANY) {
3508                         SV **svp = AvARRAY(PL_comppad_name);
3509                         SV *sv = svp[curop->op_targ];
3510                         if (SvCUR(sv) == PL_generation)
3511                             break;
3512                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3513                     }
3514                     else if (curop->op_type == OP_RV2CV)
3515                         break;
3516                     else if (curop->op_type == OP_RV2SV ||
3517                              curop->op_type == OP_RV2AV ||
3518                              curop->op_type == OP_RV2HV ||
3519                              curop->op_type == OP_RV2GV) {
3520                         if (lastop->op_type != OP_GV)   /* funny deref? */
3521                             break;
3522                     }
3523                     else if (curop->op_type == OP_PUSHRE) {
3524                         if (((PMOP*)curop)->op_pmreplroot) {
3525 #ifdef USE_ITHREADS
3526                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3527 #else
3528                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3529 #endif
3530                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3531                                 break;
3532                             SvCUR(gv) = PL_generation;
3533                         }
3534                     }
3535                     else
3536                         break;
3537                 }
3538                 lastop = curop;
3539             }
3540             if (curop != o)
3541                 o->op_private |= OPpASSIGN_COMMON;
3542         }
3543         if (right && right->op_type == OP_SPLIT) {
3544             OP* tmpop;
3545             if ((tmpop = ((LISTOP*)right)->op_first) &&
3546                 tmpop->op_type == OP_PUSHRE)
3547             {
3548                 PMOP *pm = (PMOP*)tmpop;
3549                 if (left->op_type == OP_RV2AV &&
3550                     !(left->op_private & OPpLVAL_INTRO) &&
3551                     !(o->op_private & OPpASSIGN_COMMON) )
3552                 {
3553                     tmpop = ((UNOP*)left)->op_first;
3554                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3555 #ifdef USE_ITHREADS
3556                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3557                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3558 #else
3559                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3560                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3561 #endif
3562                         pm->op_pmflags |= PMf_ONCE;
3563                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3564                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3565                         tmpop->op_sibling = Nullop;     /* don't free split */
3566                         right->op_next = tmpop->op_next;  /* fix starting loc */
3567                         op_free(o);                     /* blow off assign */
3568                         right->op_flags &= ~OPf_WANT;
3569                                 /* "I don't know and I don't care." */
3570                         return right;
3571                     }
3572                 }
3573                 else {
3574                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3575                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3576                     {
3577                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3578                         if (SvIVX(sv) == 0)
3579                             sv_setiv(sv, PL_modcount+1);
3580                     }
3581                 }
3582             }
3583         }
3584         return o;
3585     }
3586     if (!right)
3587         right = newOP(OP_UNDEF, 0);
3588     if (right->op_type == OP_READLINE) {
3589         right->op_flags |= OPf_STACKED;
3590         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3591     }
3592     else {
3593         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3594         o = newBINOP(OP_SASSIGN, flags,
3595             scalar(right), mod(scalar(left), OP_SASSIGN) );
3596         if (PL_eval_start)
3597             PL_eval_start = 0;
3598         else {
3599             op_free(o);
3600             return Nullop;
3601         }
3602     }
3603     return o;
3604 }
3605
3606 OP *
3607 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3608 {
3609     U32 seq = intro_my();
3610     register COP *cop;
3611
3612     NewOp(1101, cop, 1, COP);
3613     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3614         cop->op_type = OP_DBSTATE;
3615         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3616     }
3617     else {
3618         cop->op_type = OP_NEXTSTATE;
3619         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3620     }
3621     cop->op_flags = flags;
3622     cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3623 #ifdef NATIVE_HINTS
3624     cop->op_private |= NATIVE_HINTS;
3625 #endif
3626     PL_compiling.op_private = cop->op_private;
3627     cop->op_next = (OP*)cop;
3628
3629     if (label) {
3630         cop->cop_label = label;
3631         PL_hints |= HINT_BLOCK_SCOPE;
3632     }
3633     cop->cop_seq = seq;
3634     cop->cop_arybase = PL_curcop->cop_arybase;
3635     if (specialWARN(PL_curcop->cop_warnings))
3636         cop->cop_warnings = PL_curcop->cop_warnings ;
3637     else
3638         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3639     if (specialCopIO(PL_curcop->cop_io))
3640         cop->cop_io = PL_curcop->cop_io;
3641     else
3642         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3643
3644
3645     if (PL_copline == NOLINE)
3646         CopLINE_set(cop, CopLINE(PL_curcop));
3647     else {
3648         CopLINE_set(cop, PL_copline);
3649         PL_copline = NOLINE;
3650     }
3651 #ifdef USE_ITHREADS
3652     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3653 #else
3654     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3655 #endif
3656     CopSTASH_set(cop, PL_curstash);
3657
3658     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3659         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3660         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3661             (void)SvIOK_on(*svp);
3662             SvIVX(*svp) = PTR2IV(cop);
3663         }
3664     }
3665
3666     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3667 }
3668
3669 /* "Introduce" my variables to visible status. */
3670 U32
3671 Perl_intro_my(pTHX)
3672 {
3673     SV **svp;
3674     SV *sv;
3675     I32 i;
3676
3677     if (! PL_min_intro_pending)
3678         return PL_cop_seqmax;
3679
3680     svp = AvARRAY(PL_comppad_name);
3681     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3682         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3683             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3684             SvNVX(sv) = (NV)PL_cop_seqmax;
3685         }
3686     }
3687     PL_min_intro_pending = 0;
3688     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3689     return PL_cop_seqmax++;
3690 }
3691
3692 OP *
3693 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3694 {
3695     return new_logop(type, flags, &first, &other);
3696 }
3697
3698 STATIC OP *
3699 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3700 {
3701     LOGOP *logop;
3702     OP *o;
3703     OP *first = *firstp;
3704     OP *other = *otherp;
3705
3706     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3707         return newBINOP(type, flags, scalar(first), scalar(other));
3708
3709     scalarboolean(first);
3710     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3711     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3712         if (type == OP_AND || type == OP_OR) {
3713             if (type == OP_AND)
3714                 type = OP_OR;
3715             else
3716                 type = OP_AND;
3717             o = first;
3718             first = *firstp = cUNOPo->op_first;
3719             if (o->op_next)
3720                 first->op_next = o->op_next;
3721             cUNOPo->op_first = Nullop;
3722             op_free(o);
3723         }
3724     }
3725     if (first->op_type == OP_CONST) {
3726         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3727             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3728         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3729             op_free(first);
3730             *firstp = Nullop;
3731             return other;
3732         }
3733         else {
3734             op_free(other);
3735             *otherp = Nullop;
3736             return first;
3737         }
3738     }
3739     else if (first->op_type == OP_WANTARRAY) {
3740         if (type == OP_AND)
3741             list(other);
3742         else
3743             scalar(other);
3744     }
3745     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3746         OP *k1 = ((UNOP*)first)->op_first;
3747         OP *k2 = k1->op_sibling;
3748         OPCODE warnop = 0;
3749         switch (first->op_type)
3750         {
3751         case OP_NULL:
3752             if (k2 && k2->op_type == OP_READLINE
3753                   && (k2->op_flags & OPf_STACKED)
3754                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3755             {
3756                 warnop = k2->op_type;
3757             }
3758             break;
3759
3760         case OP_SASSIGN:
3761             if (k1->op_type == OP_READDIR
3762                   || k1->op_type == OP_GLOB
3763                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3764                   || k1->op_type == OP_EACH)
3765             {
3766                 warnop = ((k1->op_type == OP_NULL)
3767                           ? k1->op_targ : k1->op_type);
3768             }
3769             break;
3770         }
3771         if (warnop) {
3772             line_t oldline = CopLINE(PL_curcop);
3773             CopLINE_set(PL_curcop, PL_copline);
3774             Perl_warner(aTHX_ WARN_MISC,
3775                  "Value of %s%s can be \"0\"; test with defined()",
3776                  PL_op_desc[warnop],
3777                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3778                   ? " construct" : "() operator"));
3779             CopLINE_set(PL_curcop, oldline);
3780         }
3781     }
3782
3783     if (!other)
3784         return first;
3785
3786     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3787         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3788
3789     NewOp(1101, logop, 1, LOGOP);
3790
3791     logop->op_type = type;
3792     logop->op_ppaddr = PL_ppaddr[type];
3793     logop->op_first = first;
3794     logop->op_flags = flags | OPf_KIDS;
3795     logop->op_other = LINKLIST(other);
3796     logop->op_private = 1 | (flags >> 8);
3797
3798     /* establish postfix order */
3799     logop->op_next = LINKLIST(first);
3800     first->op_next = (OP*)logop;
3801     first->op_sibling = other;
3802
3803     o = newUNOP(OP_NULL, 0, (OP*)logop);
3804     other->op_next = o;
3805
3806     return o;
3807 }
3808
3809 OP *
3810 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3811 {
3812     LOGOP *logop;
3813     OP *start;
3814     OP *o;
3815
3816     if (!falseop)
3817         return newLOGOP(OP_AND, 0, first, trueop);
3818     if (!trueop)
3819         return newLOGOP(OP_OR, 0, first, falseop);
3820
3821     scalarboolean(first);
3822     if (first->op_type == OP_CONST) {
3823         if (SvTRUE(((SVOP*)first)->op_sv)) {
3824             op_free(first);
3825             op_free(falseop);
3826             return trueop;
3827         }
3828         else {
3829             op_free(first);
3830             op_free(trueop);
3831             return falseop;
3832         }
3833     }
3834     else if (first->op_type == OP_WANTARRAY) {
3835         list(trueop);
3836         scalar(falseop);
3837     }
3838     NewOp(1101, logop, 1, LOGOP);
3839     logop->op_type = OP_COND_EXPR;
3840     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3841     logop->op_first = first;
3842     logop->op_flags = flags | OPf_KIDS;
3843     logop->op_private = 1 | (flags >> 8);
3844     logop->op_other = LINKLIST(trueop);
3845     logop->op_next = LINKLIST(falseop);
3846
3847
3848     /* establish postfix order */
3849     start = LINKLIST(first);
3850     first->op_next = (OP*)logop;
3851
3852     first->op_sibling = trueop;
3853     trueop->op_sibling = falseop;
3854     o = newUNOP(OP_NULL, 0, (OP*)logop);
3855
3856     trueop->op_next = falseop->op_next = o;
3857
3858     o->op_next = start;
3859     return o;
3860 }
3861
3862 OP *
3863 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3864 {
3865     LOGOP *range;
3866     OP *flip;
3867     OP *flop;
3868     OP *leftstart;
3869     OP *o;
3870
3871     NewOp(1101, range, 1, LOGOP);
3872
3873     range->op_type = OP_RANGE;
3874     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3875     range->op_first = left;
3876     range->op_flags = OPf_KIDS;
3877     leftstart = LINKLIST(left);
3878     range->op_other = LINKLIST(right);
3879     range->op_private = 1 | (flags >> 8);
3880
3881     left->op_sibling = right;
3882
3883     range->op_next = (OP*)range;
3884     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3885     flop = newUNOP(OP_FLOP, 0, flip);
3886     o = newUNOP(OP_NULL, 0, flop);
3887     linklist(flop);
3888     range->op_next = leftstart;
3889
3890     left->op_next = flip;
3891     right->op_next = flop;
3892
3893     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3894     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3895     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3896     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3897
3898     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3899     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3900
3901     flip->op_next = o;
3902     if (!flip->op_private || !flop->op_private)
3903         linklist(o);            /* blow off optimizer unless constant */
3904
3905     return o;
3906 }
3907
3908 OP *
3909 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3910 {
3911     OP* listop;
3912     OP* o;
3913     int once = block && block->op_flags & OPf_SPECIAL &&
3914       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3915
3916     if (expr) {
3917         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3918             return block;       /* do {} while 0 does once */
3919         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3920             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3921             expr = newUNOP(OP_DEFINED, 0,
3922                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3923         } else if (expr->op_flags & OPf_KIDS) {
3924             OP *k1 = ((UNOP*)expr)->op_first;
3925             OP *k2 = (k1) ? k1->op_sibling : NULL;
3926             switch (expr->op_type) {
3927               case OP_NULL:
3928                 if (k2 && k2->op_type == OP_READLINE
3929                       && (k2->op_flags & OPf_STACKED)
3930                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3931                     expr = newUNOP(OP_DEFINED, 0, expr);
3932                 break;
3933
3934               case OP_SASSIGN:
3935                 if (k1->op_type == OP_READDIR
3936                       || k1->op_type == OP_GLOB
3937                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3938                       || k1->op_type == OP_EACH)
3939                     expr = newUNOP(OP_DEFINED, 0, expr);
3940                 break;
3941             }
3942         }
3943     }
3944
3945     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3946     o = new_logop(OP_AND, 0, &expr, &listop);
3947
3948     if (listop)
3949         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3950
3951     if (once && o != listop)
3952         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3953
3954     if (o == listop)
3955         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3956
3957     o->op_flags |= flags;
3958     o = scope(o);
3959     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3960     return o;
3961 }
3962
3963 OP *
3964 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3965 {
3966     OP *redo;
3967     OP *next = 0;
3968     OP *listop;
3969     OP *o;
3970     U8 loopflags = 0;
3971
3972     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3973                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3974         expr = newUNOP(OP_DEFINED, 0,
3975             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3976     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3977         OP *k1 = ((UNOP*)expr)->op_first;
3978         OP *k2 = (k1) ? k1->op_sibling : NULL;
3979         switch (expr->op_type) {
3980           case OP_NULL:
3981             if (k2 && k2->op_type == OP_READLINE
3982                   && (k2->op_flags & OPf_STACKED)
3983                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3984                 expr = newUNOP(OP_DEFINED, 0, expr);
3985             break;
3986
3987           case OP_SASSIGN:
3988             if (k1->op_type == OP_READDIR
3989                   || k1->op_type == OP_GLOB
3990                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3991                   || k1->op_type == OP_EACH)
3992                 expr = newUNOP(OP_DEFINED, 0, expr);
3993             break;
3994         }
3995     }
3996
3997     if (!block)
3998         block = newOP(OP_NULL, 0);
3999     else if (cont) {
4000         block = scope(block);
4001     }
4002
4003     if (cont) {
4004         next = LINKLIST(cont);
4005     }
4006     if (expr) {
4007         OP *unstack = newOP(OP_UNSTACK, 0);
4008         if (!next)
4009             next = unstack;
4010         cont = append_elem(OP_LINESEQ, cont, unstack);
4011         if ((line_t)whileline != NOLINE) {
4012             PL_copline = whileline;
4013             cont = append_elem(OP_LINESEQ, cont,
4014                                newSTATEOP(0, Nullch, Nullop));
4015         }
4016     }
4017
4018     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4019     redo = LINKLIST(listop);
4020
4021     if (expr) {
4022         PL_copline = whileline;
4023         scalar(listop);
4024         o = new_logop(OP_AND, 0, &expr, &listop);
4025         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4026             op_free(expr);              /* oops, it's a while (0) */
4027             op_free((OP*)loop);
4028             return Nullop;              /* listop already freed by new_logop */
4029         }
4030         if (listop)
4031             ((LISTOP*)listop)->op_last->op_next =
4032                 (o == listop ? redo : LINKLIST(o));
4033     }
4034     else
4035         o = listop;
4036
4037     if (!loop) {
4038         NewOp(1101,loop,1,LOOP);
4039         loop->op_type = OP_ENTERLOOP;
4040         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4041         loop->op_private = 0;
4042         loop->op_next = (OP*)loop;
4043     }
4044
4045     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4046
4047     loop->op_redoop = redo;
4048     loop->op_lastop = o;
4049     o->op_private |= loopflags;
4050
4051     if (next)
4052         loop->op_nextop = next;
4053     else
4054         loop->op_nextop = o;
4055
4056     o->op_flags |= flags;
4057     o->op_private |= (flags >> 8);
4058     return o;
4059 }
4060
4061 OP *
4062 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4063 {
4064     LOOP *loop;
4065     OP *wop;
4066     int padoff = 0;
4067     I32 iterflags = 0;
4068
4069     if (sv) {
4070         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4071             sv->op_type = OP_RV2GV;
4072             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4073         }
4074         else if (sv->op_type == OP_PADSV) { /* private variable */
4075             padoff = sv->op_targ;
4076             sv->op_targ = 0;
4077             op_free(sv);
4078             sv = Nullop;
4079         }
4080         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4081             padoff = sv->op_targ;
4082             sv->op_targ = 0;
4083             iterflags |= OPf_SPECIAL;
4084             op_free(sv);
4085             sv = Nullop;
4086         }
4087         else
4088             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4089     }
4090     else {
4091 #ifdef USE_THREADS
4092         padoff = find_threadsv("_");
4093         iterflags |= OPf_SPECIAL;
4094 #else
4095         sv = newGVOP(OP_GV, 0, PL_defgv);
4096 #endif
4097     }
4098     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4099         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4100         iterflags |= OPf_STACKED;
4101     }
4102     else if (expr->op_type == OP_NULL &&
4103              (expr->op_flags & OPf_KIDS) &&
4104              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4105     {
4106         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4107          * set the STACKED flag to indicate that these values are to be
4108          * treated as min/max values by 'pp_iterinit'.
4109          */
4110         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4111         LOGOP* range = (LOGOP*) flip->op_first;
4112         OP* left  = range->op_first;
4113         OP* right = left->op_sibling;
4114         LISTOP* listop;
4115
4116         range->op_flags &= ~OPf_KIDS;
4117         range->op_first = Nullop;
4118
4119         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4120         listop->op_first->op_next = range->op_next;
4121         left->op_next = range->op_other;
4122         right->op_next = (OP*)listop;
4123         listop->op_next = listop->op_first;
4124
4125         op_free(expr);
4126         expr = (OP*)(listop);
4127         op_null(expr);
4128         iterflags |= OPf_STACKED;
4129     }
4130     else {
4131         expr = mod(force_list(expr), OP_GREPSTART);
4132     }
4133
4134
4135     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4136                                append_elem(OP_LIST, expr, scalar(sv))));
4137     assert(!loop->op_next);
4138 #ifdef PL_OP_SLAB_ALLOC
4139     {
4140         LOOP *tmp;
4141         NewOp(1234,tmp,1,LOOP);
4142         Copy(loop,tmp,1,LOOP);
4143         loop = tmp;
4144     }
4145 #else
4146     Renew(loop, 1, LOOP);
4147 #endif
4148     loop->op_targ = padoff;
4149     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4150     PL_copline = forline;
4151     return newSTATEOP(0, label, wop);
4152 }
4153
4154 OP*
4155 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4156 {
4157     OP *o;
4158     STRLEN n_a;
4159
4160     if (type != OP_GOTO || label->op_type == OP_CONST) {
4161         /* "last()" means "last" */
4162         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4163             o = newOP(type, OPf_SPECIAL);
4164         else {
4165             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4166                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4167                                         : ""));
4168         }
4169         op_free(label);
4170     }
4171     else {
4172         if (label->op_type == OP_ENTERSUB)
4173             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4174         o = newUNOP(type, OPf_STACKED, label);
4175     }
4176     PL_hints |= HINT_BLOCK_SCOPE;
4177     return o;
4178 }
4179
4180 void
4181 Perl_cv_undef(pTHX_ CV *cv)
4182 {
4183 #ifdef USE_THREADS
4184     if (CvMUTEXP(cv)) {
4185         MUTEX_DESTROY(CvMUTEXP(cv));
4186         Safefree(CvMUTEXP(cv));
4187         CvMUTEXP(cv) = 0;
4188     }
4189 #endif /* USE_THREADS */
4190
4191 #ifdef USE_ITHREADS
4192     if (CvFILE(cv) && !CvXSUB(cv)) {
4193         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4194         Safefree(CvFILE(cv));
4195     }
4196     CvFILE(cv) = 0;
4197 #endif
4198
4199     if (!CvXSUB(cv) && CvROOT(cv)) {
4200 #ifdef USE_THREADS
4201         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4202             Perl_croak(aTHX_ "Can't undef active subroutine");
4203 #else
4204         if (CvDEPTH(cv))
4205             Perl_croak(aTHX_ "Can't undef active subroutine");
4206 #endif /* USE_THREADS */
4207         ENTER;
4208
4209         SAVEVPTR(PL_curpad);
4210         PL_curpad = 0;
4211
4212         op_free(CvROOT(cv));
4213         CvROOT(cv) = Nullop;
4214         LEAVE;
4215     }
4216     SvPOK_off((SV*)cv);         /* forget prototype */
4217     CvGV(cv) = Nullgv;
4218     /* Since closure prototypes have the same lifetime as the containing
4219      * CV, they don't hold a refcount on the outside CV.  This avoids
4220      * the refcount loop between the outer CV (which keeps a refcount to
4221      * the closure prototype in the pad entry for pp_anoncode()) and the
4222      * closure prototype, and the ensuing memory leak.  This does not
4223      * apply to closures generated within eval"", since eval"" CVs are
4224      * ephemeral. --GSAR */
4225     if (!CvANON(cv) || CvCLONED(cv)
4226         || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4227             && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4228     {
4229         SvREFCNT_dec(CvOUTSIDE(cv));
4230     }
4231     CvOUTSIDE(cv) = Nullcv;
4232     if (CvCONST(cv)) {
4233         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4234         CvCONST_off(cv);
4235     }
4236     if (CvPADLIST(cv)) {
4237         /* may be during global destruction */
4238         if (SvREFCNT(CvPADLIST(cv))) {
4239             I32 i = AvFILLp(CvPADLIST(cv));
4240             while (i >= 0) {
4241                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4242                 SV* sv = svp ? *svp : Nullsv;
4243                 if (!sv)
4244                     continue;
4245                 if (sv == (SV*)PL_comppad_name)
4246                     PL_comppad_name = Nullav;
4247                 else if (sv == (SV*)PL_comppad) {
4248                     PL_comppad = Nullav;
4249                     PL_curpad = Null(SV**);
4250                 }
4251                 SvREFCNT_dec(sv);
4252             }
4253             SvREFCNT_dec((SV*)CvPADLIST(cv));
4254         }
4255         CvPADLIST(cv) = Nullav;
4256     }
4257     if (CvXSUB(cv)) {
4258         CvXSUB(cv) = 0;
4259     }
4260     CvFLAGS(cv) = 0;
4261 }
4262
4263 #ifdef DEBUG_CLOSURES
4264 STATIC void
4265 S_cv_dump(pTHX_ CV *cv)
4266 {
4267 #ifdef DEBUGGING
4268     CV *outside = CvOUTSIDE(cv);
4269     AV* padlist = CvPADLIST(cv);
4270     AV* pad_name;
4271     AV* pad;
4272     SV** pname;
4273     SV** ppad;
4274     I32 ix;
4275
4276     PerlIO_printf(Perl_debug_log,
4277                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4278                   PTR2UV(cv),
4279                   (CvANON(cv) ? "ANON"
4280                    : (cv == PL_main_cv) ? "MAIN"
4281                    : CvUNIQUE(cv) ? "UNIQUE"
4282                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4283                   PTR2UV(outside),
4284                   (!outside ? "null"
4285                    : CvANON(outside) ? "ANON"
4286                    : (outside == PL_main_cv) ? "MAIN"
4287                    : CvUNIQUE(outside) ? "UNIQUE"
4288                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4289
4290     if (!padlist)
4291         return;
4292
4293     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4294     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4295     pname = AvARRAY(pad_name);
4296     ppad = AvARRAY(pad);
4297
4298     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4299         if (SvPOK(pname[ix]))
4300             PerlIO_printf(Perl_debug_log,
4301                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4302                           (int)ix, PTR2UV(ppad[ix]),
4303                           SvFAKE(pname[ix]) ? "FAKE " : "",
4304                           SvPVX(pname[ix]),
4305                           (IV)I_32(SvNVX(pname[ix])),
4306                           SvIVX(pname[ix]));
4307     }
4308 #endif /* DEBUGGING */
4309 }
4310 #endif /* DEBUG_CLOSURES */
4311
4312 STATIC CV *
4313 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4314 {
4315     AV* av;
4316     I32 ix;
4317     AV* protopadlist = CvPADLIST(proto);
4318     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4319     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4320     SV** pname = AvARRAY(protopad_name);
4321     SV** ppad = AvARRAY(protopad);
4322     I32 fname = AvFILLp(protopad_name);
4323     I32 fpad = AvFILLp(protopad);
4324     AV* comppadlist;
4325     CV* cv;
4326
4327     assert(!CvUNIQUE(proto));
4328
4329     ENTER;
4330     SAVECOMPPAD();
4331     SAVESPTR(PL_comppad_name);
4332     SAVESPTR(PL_compcv);
4333
4334     cv = PL_compcv = (CV*)NEWSV(1104,0);
4335     sv_upgrade((SV *)cv, SvTYPE(proto));
4336     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4337     CvCLONED_on(cv);
4338
4339 #ifdef USE_THREADS
4340     New(666, CvMUTEXP(cv), 1, perl_mutex);
4341     MUTEX_INIT(CvMUTEXP(cv));
4342     CvOWNER(cv)         = 0;
4343 #endif /* USE_THREADS */
4344 #ifdef USE_ITHREADS
4345     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
4346                                         : savepv(CvFILE(proto));
4347 #else
4348     CvFILE(cv)          = CvFILE(proto);
4349 #endif
4350     CvGV(cv)            = CvGV(proto);
4351     CvSTASH(cv)         = CvSTASH(proto);
4352     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4353     CvSTART(cv)         = CvSTART(proto);
4354     if (outside)
4355         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4356
4357     if (SvPOK(proto))
4358         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4359
4360     PL_comppad_name = newAV();
4361     for (ix = fname; ix >= 0; ix--)
4362         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4363
4364     PL_comppad = newAV();
4365
4366     comppadlist = newAV();
4367     AvREAL_off(comppadlist);
4368     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4369     av_store(comppadlist, 1, (SV*)PL_comppad);
4370     CvPADLIST(cv) = comppadlist;
4371     av_fill(PL_comppad, AvFILLp(protopad));
4372     PL_curpad = AvARRAY(PL_comppad);
4373
4374     av = newAV();           /* will be @_ */
4375     av_extend(av, 0);
4376     av_store(PL_comppad, 0, (SV*)av);
4377     AvFLAGS(av) = AVf_REIFY;
4378
4379     for (ix = fpad; ix > 0; ix--) {
4380         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4381         if (namesv && namesv != &PL_sv_undef) {
4382             char *name = SvPVX(namesv);    /* XXX */
4383             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4384                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4385                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4386                 if (!off)
4387                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4388                 else if (off != ix)
4389                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4390             }
4391             else {                              /* our own lexical */
4392                 SV* sv;
4393                 if (*name == '&') {
4394                     /* anon code -- we'll come back for it */
4395                     sv = SvREFCNT_inc(ppad[ix]);
4396                 }
4397                 else if (*name == '@')
4398                     sv = (SV*)newAV();
4399                 else if (*name == '%')
4400                     sv = (SV*)newHV();
4401                 else
4402                     sv = NEWSV(0,0);
4403                 if (!SvPADBUSY(sv))
4404                     SvPADMY_on(sv);
4405                 PL_curpad[ix] = sv;
4406             }
4407         }
4408         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4409             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4410         }
4411         else {
4412             SV* sv = NEWSV(0,0);
4413             SvPADTMP_on(sv);
4414             PL_curpad[ix] = sv;
4415         }
4416     }
4417
4418     /* Now that vars are all in place, clone nested closures. */
4419
4420     for (ix = fpad; ix > 0; ix--) {
4421         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4422         if (namesv
4423             && namesv != &PL_sv_undef
4424             && !(SvFLAGS(namesv) & SVf_FAKE)
4425             && *SvPVX(namesv) == '&'
4426             && CvCLONE(ppad[ix]))
4427         {
4428             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4429             SvREFCNT_dec(ppad[ix]);
4430             CvCLONE_on(kid);
4431             SvPADMY_on(kid);
4432             PL_curpad[ix] = (SV*)kid;
4433         }
4434     }
4435
4436 #ifdef DEBUG_CLOSURES
4437     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4438     cv_dump(outside);
4439     PerlIO_printf(Perl_debug_log, "  from:\n");
4440     cv_dump(proto);
4441     PerlIO_printf(Perl_debug_log, "   to:\n");
4442     cv_dump(cv);
4443 #endif
4444
4445     LEAVE;
4446
4447     if (CvCONST(cv)) {
4448         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4449         assert(const_sv);
4450         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4451         SvREFCNT_dec(cv);
4452         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4453     }
4454
4455     return cv;
4456 }
4457
4458 CV *
4459 Perl_cv_clone(pTHX_ CV *proto)
4460 {
4461     CV *cv;
4462     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4463     cv = cv_clone2(proto, CvOUTSIDE(proto));
4464     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4465     return cv;
4466 }
4467
4468 void
4469 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4470 {
4471     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4472         SV* msg = sv_newmortal();
4473         SV* name = Nullsv;
4474
4475         if (gv)
4476             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4477         sv_setpv(msg, "Prototype mismatch:");
4478         if (name)
4479             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4480         if (SvPOK(cv))
4481             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4482         sv_catpv(msg, " vs ");
4483         if (p)
4484             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4485         else
4486             sv_catpv(msg, "none");
4487         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4488     }
4489 }
4490
4491 static void const_sv_xsub(pTHXo_ CV* cv);
4492
4493 /*
4494 =for apidoc cv_const_sv
4495
4496 If C<cv> is a constant sub eligible for inlining. returns the constant
4497 value returned by the sub.  Otherwise, returns NULL.
4498
4499 Constant subs can be created with C<newCONSTSUB> or as described in
4500 L<perlsub/"Constant Functions">.
4501
4502 =cut
4503 */
4504 SV *
4505 Perl_cv_const_sv(pTHX_ CV *cv)
4506 {
4507     if (!cv || !CvCONST(cv))
4508         return Nullsv;
4509     return (SV*)CvXSUBANY(cv).any_ptr;
4510 }
4511
4512 SV *
4513 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4514 {
4515     SV *sv = Nullsv;
4516
4517     if (!o)
4518         return Nullsv;
4519
4520     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4521         o = cLISTOPo->op_first->op_sibling;
4522
4523     for (; o; o = o->op_next) {
4524         OPCODE type = o->op_type;
4525
4526         if (sv && o->op_next == o)
4527             return sv;
4528         if (o->op_next != o) {
4529             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4530                 continue;
4531             if (type == OP_DBSTATE)
4532                 continue;
4533         }
4534         if (type == OP_LEAVESUB || type == OP_RETURN)
4535             break;
4536         if (sv)
4537             return Nullsv;
4538         if (type == OP_CONST && cSVOPo->op_sv)
4539             sv = cSVOPo->op_sv;
4540         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4541             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4542             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4543             if (!sv)
4544                 return Nullsv;
4545             if (CvCONST(cv)) {
4546                 /* We get here only from cv_clone2() while creating a closure.
4547                    Copy the const value here instead of in cv_clone2 so that
4548                    SvREADONLY_on doesn't lead to problems when leaving
4549                    scope.
4550                 */
4551                 sv = newSVsv(sv);
4552             }
4553             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4554                 return Nullsv;
4555         }
4556         else
4557             return Nullsv;
4558     }
4559     if (sv)
4560         SvREADONLY_on(sv);
4561     return sv;
4562 }
4563
4564 void
4565 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4566 {
4567     if (o)
4568         SAVEFREEOP(o);
4569     if (proto)
4570         SAVEFREEOP(proto);
4571     if (attrs)
4572         SAVEFREEOP(attrs);
4573     if (block)
4574         SAVEFREEOP(block);
4575     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4576 }
4577
4578 CV *
4579 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4580 {
4581     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4582 }
4583
4584 CV *
4585 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4586 {
4587     STRLEN n_a;
4588     char *name;
4589     char *aname;
4590     GV *gv;
4591     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4592     register CV *cv=0;
4593     I32 ix;
4594     SV *const_sv;
4595
4596     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4597     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4598         SV *sv = sv_newmortal();
4599         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4600                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4601         aname = SvPVX(sv);
4602     }
4603     else
4604         aname = Nullch;
4605     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4606                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4607                     SVt_PVCV);
4608
4609     if (o)
4610         SAVEFREEOP(o);
4611     if (proto)
4612         SAVEFREEOP(proto);
4613     if (attrs)
4614         SAVEFREEOP(attrs);
4615
4616     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4617                                            maximum a prototype before. */
4618         if (SvTYPE(gv) > SVt_NULL) {
4619             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4620                 && ckWARN_d(WARN_PROTOTYPE))
4621             {
4622                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4623             }
4624             cv_ckproto((CV*)gv, NULL, ps);
4625         }
4626         if (ps)
4627             sv_setpv((SV*)gv, ps);
4628         else
4629             sv_setiv((SV*)gv, -1);
4630         SvREFCNT_dec(PL_compcv);
4631         cv = PL_compcv = NULL;
4632         PL_sub_generation++;
4633         goto done;
4634     }
4635
4636     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4637
4638 #ifdef GV_UNIQUE_CHECK
4639     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4640         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4641     }
4642 #endif
4643
4644     if (!block || !ps || *ps || attrs)
4645         const_sv = Nullsv;
4646     else
4647         const_sv = op_const_sv(block, Nullcv);
4648
4649     if (cv) {
4650         bool exists = CvROOT(cv) || CvXSUB(cv);
4651
4652 #ifdef GV_UNIQUE_CHECK
4653         if (exists && GvUNIQUE(gv)) {
4654             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4655         }
4656 #endif
4657
4658         /* if the subroutine doesn't exist and wasn't pre-declared
4659          * with a prototype, assume it will be AUTOLOADed,
4660          * skipping the prototype check
4661          */
4662         if (exists || SvPOK(cv))
4663             cv_ckproto(cv, gv, ps);
4664         /* already defined (or promised)? */
4665         if (exists || GvASSUMECV(gv)) {
4666             if (!block && !attrs) {
4667                 /* just a "sub foo;" when &foo is already defined */
4668                 SAVEFREESV(PL_compcv);
4669                 goto done;
4670             }
4671             /* ahem, death to those who redefine active sort subs */
4672             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4673                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4674             if (block) {
4675                 if (ckWARN(WARN_REDEFINE)
4676                     || (CvCONST(cv)
4677                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4678                 {
4679                     line_t oldline = CopLINE(PL_curcop);
4680                     CopLINE_set(PL_curcop, PL_copline);
4681                     Perl_warner(aTHX_ WARN_REDEFINE,
4682                         CvCONST(cv) ? "Constant subroutine %s redefined"
4683                                     : "Subroutine %s redefined", name);
4684                     CopLINE_set(PL_curcop, oldline);
4685                 }
4686                 SvREFCNT_dec(cv);
4687                 cv = Nullcv;
4688             }
4689         }
4690     }
4691     if (const_sv) {
4692         SvREFCNT_inc(const_sv);
4693         if (cv) {
4694             assert(!CvROOT(cv) && !CvCONST(cv));
4695             sv_setpv((SV*)cv, "");  /* prototype is "" */
4696             CvXSUBANY(cv).any_ptr = const_sv;
4697             CvXSUB(cv) = const_sv_xsub;
4698             CvCONST_on(cv);
4699         }
4700         else {
4701             GvCV(gv) = Nullcv;
4702             cv = newCONSTSUB(NULL, name, const_sv);
4703         }
4704         op_free(block);
4705         SvREFCNT_dec(PL_compcv);
4706         PL_compcv = NULL;
4707         PL_sub_generation++;
4708         goto done;
4709     }
4710     if (attrs) {
4711         HV *stash;
4712         SV *rcv;
4713
4714         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4715          * before we clobber PL_compcv.
4716          */
4717         if (cv && !block) {
4718             rcv = (SV*)cv;
4719             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4720                 stash = GvSTASH(CvGV(cv));
4721             else if (CvSTASH(cv))
4722                 stash = CvSTASH(cv);
4723             else
4724                 stash = PL_curstash;
4725         }
4726         else {
4727             /* possibly about to re-define existing subr -- ignore old cv */
4728             rcv = (SV*)PL_compcv;
4729             if (name && GvSTASH(gv))
4730                 stash = GvSTASH(gv);
4731             else
4732                 stash = PL_curstash;
4733         }
4734         apply_attrs(stash, rcv, attrs);
4735     }
4736     if (cv) {                           /* must reuse cv if autoloaded */
4737         if (!block) {
4738             /* got here with just attrs -- work done, so bug out */
4739             SAVEFREESV(PL_compcv);
4740             goto done;
4741         }
4742         cv_undef(cv);
4743         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4744         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4745         CvOUTSIDE(PL_compcv) = 0;
4746         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4747         CvPADLIST(PL_compcv) = 0;
4748         /* inner references to PL_compcv must be fixed up ... */
4749         {
4750             AV *padlist = CvPADLIST(cv);
4751             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4752             AV *comppad = (AV*)AvARRAY(padlist)[1];
4753             SV **namepad = AvARRAY(comppad_name);
4754             SV **curpad = AvARRAY(comppad);
4755             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4756                 SV *namesv = namepad[ix];
4757                 if (namesv && namesv != &PL_sv_undef
4758                     && *SvPVX(namesv) == '&')
4759                 {
4760                     CV *innercv = (CV*)curpad[ix];
4761                     if (CvOUTSIDE(innercv) == PL_compcv) {
4762                         CvOUTSIDE(innercv) = cv;
4763                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4764                             (void)SvREFCNT_inc(cv);
4765                             SvREFCNT_dec(PL_compcv);
4766                         }
4767                     }
4768                 }
4769             }
4770         }
4771         /* ... before we throw it away */
4772         SvREFCNT_dec(PL_compcv);
4773         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4774           ++PL_sub_generation;
4775     }
4776     else {
4777         cv = PL_compcv;
4778         if (name) {
4779             GvCV(gv) = cv;
4780             GvCVGEN(gv) = 0;
4781             PL_sub_generation++;
4782         }
4783     }
4784     CvGV(cv) = gv;
4785     CvFILE_set_from_cop(cv, PL_curcop);
4786     CvSTASH(cv) = PL_curstash;
4787 #ifdef USE_THREADS
4788     CvOWNER(cv) = 0;
4789     if (!CvMUTEXP(cv)) {
4790         New(666, CvMUTEXP(cv), 1, perl_mutex);
4791         MUTEX_INIT(CvMUTEXP(cv));
4792     }
4793 #endif /* USE_THREADS */
4794
4795     if (ps)
4796         sv_setpv((SV*)cv, ps);
4797
4798     if (PL_error_count) {
4799         op_free(block);
4800         block = Nullop;
4801         if (name) {
4802             char *s = strrchr(name, ':');
4803             s = s ? s+1 : name;
4804             if (strEQ(s, "BEGIN")) {
4805                 char *not_safe =
4806                     "BEGIN not safe after errors--compilation aborted";
4807                 if (PL_in_eval & EVAL_KEEPERR)
4808                     Perl_croak(aTHX_ not_safe);
4809                 else {
4810                     /* force display of errors found but not reported */
4811                     sv_catpv(ERRSV, not_safe);
4812                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4813                 }
4814             }
4815         }
4816     }
4817     if (!block)
4818         goto done;
4819
4820     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4821         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4822
4823     if (CvLVALUE(cv)) {
4824         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4825                              mod(scalarseq(block), OP_LEAVESUBLV));
4826     }
4827     else {
4828         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4829     }
4830     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4831     OpREFCNT_set(CvROOT(cv), 1);
4832     CvSTART(cv) = LINKLIST(CvROOT(cv));
4833     CvROOT(cv)->op_next = 0;
4834     CALL_PEEP(CvSTART(cv));
4835
4836     /* now that optimizer has done its work, adjust pad values */
4837     if (CvCLONE(cv)) {
4838         SV **namep = AvARRAY(PL_comppad_name);
4839         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4840             SV *namesv;
4841
4842             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4843                 continue;
4844             /*
4845              * The only things that a clonable function needs in its
4846              * pad are references to outer lexicals and anonymous subs.
4847              * The rest are created anew during cloning.
4848              */
4849             if (!((namesv = namep[ix]) != Nullsv &&
4850                   namesv != &PL_sv_undef &&
4851                   (SvFAKE(namesv) ||
4852                    *SvPVX(namesv) == '&')))
4853             {
4854                 SvREFCNT_dec(PL_curpad[ix]);
4855                 PL_curpad[ix] = Nullsv;
4856             }
4857         }
4858         assert(!CvCONST(cv));
4859         if (ps && !*ps && op_const_sv(block, cv))
4860             CvCONST_on(cv);
4861     }
4862     else {
4863         AV *av = newAV();                       /* Will be @_ */
4864         av_extend(av, 0);
4865         av_store(PL_comppad, 0, (SV*)av);
4866         AvFLAGS(av) = AVf_REIFY;
4867
4868         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4869             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4870                 continue;
4871             if (!SvPADMY(PL_curpad[ix]))
4872                 SvPADTMP_on(PL_curpad[ix]);
4873         }
4874     }
4875
4876     /* If a potential closure prototype, don't keep a refcount on
4877      * outer CV, unless the latter happens to be a passing eval"".
4878      * This is okay as the lifetime of the prototype is tied to the
4879      * lifetime of the outer CV.  Avoids memory leak due to reference
4880      * loop. --GSAR */
4881     if (!name && CvOUTSIDE(cv)
4882         && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4883              && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4884     {
4885         SvREFCNT_dec(CvOUTSIDE(cv));
4886     }
4887
4888     if (name || aname) {
4889         char *s;
4890         char *tname = (name ? name : aname);
4891
4892         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4893             SV *sv = NEWSV(0,0);
4894             SV *tmpstr = sv_newmortal();
4895             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4896             CV *pcv;
4897             HV *hv;
4898
4899             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4900                            CopFILE(PL_curcop),
4901                            (long)PL_subline, (long)CopLINE(PL_curcop));
4902             gv_efullname3(tmpstr, gv, Nullch);
4903             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4904             hv = GvHVn(db_postponed);
4905             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4906                 && (pcv = GvCV(db_postponed)))
4907             {
4908                 dSP;
4909                 PUSHMARK(SP);
4910                 XPUSHs(tmpstr);
4911                 PUTBACK;
4912                 call_sv((SV*)pcv, G_DISCARD);
4913             }
4914         }
4915
4916         if ((s = strrchr(tname,':')))
4917             s++;
4918         else
4919             s = tname;
4920
4921         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4922             goto done;
4923
4924         if (strEQ(s, "BEGIN")) {
4925             I32 oldscope = PL_scopestack_ix;
4926             ENTER;
4927             SAVECOPFILE(&PL_compiling);
4928             SAVECOPLINE(&PL_compiling);
4929             save_svref(&PL_rs);
4930             sv_setsv(PL_rs, PL_nrs);
4931
4932             if (!PL_beginav)
4933                 PL_beginav = newAV();
4934             DEBUG_x( dump_sub(gv) );
4935             av_push(PL_beginav, (SV*)cv);
4936             GvCV(gv) = 0;               /* cv has been hijacked */
4937             call_list(oldscope, PL_beginav);
4938
4939             PL_curcop = &PL_compiling;
4940             PL_compiling.op_private = PL_hints;
4941             LEAVE;
4942         }
4943         else if (strEQ(s, "END") && !PL_error_count) {
4944             if (!PL_endav)
4945                 PL_endav = newAV();
4946             DEBUG_x( dump_sub(gv) );
4947             av_unshift(PL_endav, 1);
4948             av_store(PL_endav, 0, (SV*)cv);
4949             GvCV(gv) = 0;               /* cv has been hijacked */
4950         }
4951         else if (strEQ(s, "CHECK") && !PL_error_count) {
4952             if (!PL_checkav)
4953                 PL_checkav = newAV();
4954             DEBUG_x( dump_sub(gv) );
4955             if (PL_main_start && ckWARN(WARN_VOID))
4956                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4957             av_unshift(PL_checkav, 1);
4958             av_store(PL_checkav, 0, (SV*)cv);
4959             GvCV(gv) = 0;               /* cv has been hijacked */
4960         }
4961         else if (strEQ(s, "INIT") && !PL_error_count) {
4962             if (!PL_initav)
4963                 PL_initav = newAV();
4964             DEBUG_x( dump_sub(gv) );
4965             if (PL_main_start && ckWARN(WARN_VOID))
4966                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4967             av_push(PL_initav, (SV*)cv);
4968             GvCV(gv) = 0;               /* cv has been hijacked */
4969         }
4970     }
4971
4972   done:
4973     PL_copline = NOLINE;
4974     LEAVE_SCOPE(floor);
4975     return cv;
4976 }
4977
4978 /* XXX unsafe for threads if eval_owner isn't held */
4979 /*
4980 =for apidoc newCONSTSUB
4981
4982 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4983 eligible for inlining at compile-time.
4984
4985 =cut
4986 */
4987
4988 CV *
4989 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4990 {
4991     CV* cv;
4992
4993     ENTER;
4994
4995     SAVECOPLINE(PL_curcop);
4996     CopLINE_set(PL_curcop, PL_copline);
4997
4998     SAVEHINTS();
4999     PL_hints &= ~HINT_BLOCK_SCOPE;
5000
5001     if (stash) {
5002         SAVESPTR(PL_curstash);
5003         SAVECOPSTASH(PL_curcop);
5004         PL_curstash = stash;
5005 #ifdef USE_ITHREADS
5006         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5007 #else
5008         CopSTASH(PL_curcop) = stash;
5009 #endif
5010     }
5011
5012     cv = newXS(name, const_sv_xsub, __FILE__);
5013     CvXSUBANY(cv).any_ptr = sv;
5014     CvCONST_on(cv);
5015     sv_setpv((SV*)cv, "");  /* prototype is "" */
5016
5017     LEAVE;
5018
5019     return cv;
5020 }
5021
5022 /*
5023 =for apidoc U||newXS
5024
5025 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5026
5027 =cut
5028 */
5029
5030 CV *
5031 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5032 {
5033     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5034     register CV *cv;
5035
5036     if ((cv = (name ? GvCV(gv) : Nullcv))) {
5037         if (GvCVGEN(gv)) {
5038             /* just a cached method */
5039             SvREFCNT_dec(cv);
5040             cv = 0;
5041         }
5042         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5043             /* already defined (or promised) */
5044             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5045                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5046                 line_t oldline = CopLINE(PL_curcop);
5047                 if (PL_copline != NOLINE)
5048                     CopLINE_set(PL_curcop, PL_copline);
5049                 Perl_warner(aTHX_ WARN_REDEFINE,
5050                             CvCONST(cv) ? "Constant subroutine %s redefined"
5051                                         : "Subroutine %s redefined"
5052                             ,name);
5053                 CopLINE_set(PL_curcop, oldline);
5054             }
5055             SvREFCNT_dec(cv);
5056             cv = 0;
5057         }
5058     }
5059
5060     if (cv)                             /* must reuse cv if autoloaded */
5061         cv_undef(cv);
5062     else {
5063         cv = (CV*)NEWSV(1105,0);
5064         sv_upgrade((SV *)cv, SVt_PVCV);
5065         if (name) {
5066             GvCV(gv) = cv;
5067             GvCVGEN(gv) = 0;
5068             PL_sub_generation++;
5069         }
5070     }
5071     CvGV(cv) = gv;
5072 #ifdef USE_THREADS
5073     New(666, CvMUTEXP(cv), 1, perl_mutex);
5074     MUTEX_INIT(CvMUTEXP(cv));
5075     CvOWNER(cv) = 0;
5076 #endif /* USE_THREADS */
5077     (void)gv_fetchfile(filename);
5078     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5079                                    an external constant string */
5080     CvXSUB(cv) = subaddr;
5081
5082     if (name) {
5083         char *s = strrchr(name,':');
5084         if (s)
5085             s++;
5086         else
5087             s = name;
5088
5089         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5090             goto done;
5091
5092         if (strEQ(s, "BEGIN")) {
5093             if (!PL_beginav)
5094                 PL_beginav = newAV();
5095             av_push(PL_beginav, (SV*)cv);
5096             GvCV(gv) = 0;               /* cv has been hijacked */
5097         }
5098         else if (strEQ(s, "END")) {
5099             if (!PL_endav)
5100                 PL_endav = newAV();
5101             av_unshift(PL_endav, 1);
5102             av_store(PL_endav, 0, (SV*)cv);
5103             GvCV(gv) = 0;               /* cv has been hijacked */
5104         }
5105         else if (strEQ(s, "CHECK")) {
5106             if (!PL_checkav)
5107                 PL_checkav = newAV();
5108             if (PL_main_start && ckWARN(WARN_VOID))
5109                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5110             av_unshift(PL_checkav, 1);
5111             av_store(PL_checkav, 0, (SV*)cv);
5112             GvCV(gv) = 0;               /* cv has been hijacked */
5113         }
5114         else if (strEQ(s, "INIT")) {
5115             if (!PL_initav)
5116                 PL_initav = newAV();
5117             if (PL_main_start && ckWARN(WARN_VOID))
5118                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5119             av_push(PL_initav, (SV*)cv);
5120             GvCV(gv) = 0;               /* cv has been hijacked */
5121         }
5122     }
5123     else
5124         CvANON_on(cv);
5125
5126 done:
5127     return cv;
5128 }
5129
5130 void
5131 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5132 {
5133     register CV *cv;
5134     char *name;
5135     GV *gv;
5136     I32 ix;
5137     STRLEN n_a;
5138
5139     if (o)
5140         name = SvPVx(cSVOPo->op_sv, n_a);
5141     else
5142         name = "STDOUT";
5143     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5144 #ifdef GV_UNIQUE_CHECK
5145     if (GvUNIQUE(gv)) {
5146         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5147     }
5148 #endif
5149     GvMULTI_on(gv);
5150     if ((cv = GvFORM(gv))) {
5151         if (ckWARN(WARN_REDEFINE)) {
5152             line_t oldline = CopLINE(PL_curcop);
5153
5154             CopLINE_set(PL_curcop, PL_copline);
5155             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5156             CopLINE_set(PL_curcop, oldline);
5157         }
5158         SvREFCNT_dec(cv);
5159     }
5160     cv = PL_compcv;
5161     GvFORM(gv) = cv;
5162     CvGV(cv) = gv;
5163     CvFILE_set_from_cop(cv, PL_curcop);
5164
5165     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5166         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5167             SvPADTMP_on(PL_curpad[ix]);
5168     }
5169
5170     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5171     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5172     OpREFCNT_set(CvROOT(cv), 1);
5173     CvSTART(cv) = LINKLIST(CvROOT(cv));
5174     CvROOT(cv)->op_next = 0;
5175     CALL_PEEP(CvSTART(cv));
5176     op_free(o);
5177     PL_copline = NOLINE;
5178     LEAVE_SCOPE(floor);
5179 }
5180
5181 OP *
5182 Perl_newANONLIST(pTHX_ OP *o)
5183 {
5184     return newUNOP(OP_REFGEN, 0,
5185         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5186 }
5187
5188 OP *
5189 Perl_newANONHASH(pTHX_ OP *o)
5190 {
5191     return newUNOP(OP_REFGEN, 0,
5192         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5193 }
5194
5195 OP *
5196 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5197 {
5198     return newANONATTRSUB(floor, proto, Nullop, block);
5199 }
5200
5201 OP *
5202 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5203 {
5204     return newUNOP(OP_REFGEN, 0,
5205         newSVOP(OP_ANONCODE, 0,
5206                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5207 }
5208
5209 OP *
5210 Perl_oopsAV(pTHX_ OP *o)
5211 {
5212     switch (o->op_type) {
5213     case OP_PADSV:
5214         o->op_type = OP_PADAV;
5215         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5216         return ref(o, OP_RV2AV);
5217
5218     case OP_RV2SV:
5219         o->op_type = OP_RV2AV;
5220         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5221         ref(o, OP_RV2AV);
5222         break;
5223
5224     default:
5225         if (ckWARN_d(WARN_INTERNAL))
5226             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5227         break;
5228     }
5229     return o;
5230 }
5231
5232 OP *
5233 Perl_oopsHV(pTHX_ OP *o)
5234 {
5235     switch (o->op_type) {
5236     case OP_PADSV:
5237     case OP_PADAV:
5238         o->op_type = OP_PADHV;
5239         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5240         return ref(o, OP_RV2HV);
5241
5242     case OP_RV2SV:
5243     case OP_RV2AV:
5244         o->op_type = OP_RV2HV;
5245         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5246         ref(o, OP_RV2HV);
5247         break;
5248
5249     default:
5250         if (ckWARN_d(WARN_INTERNAL))
5251             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5252         break;
5253     }
5254     return o;
5255 }
5256
5257 OP *
5258 Perl_newAVREF(pTHX_ OP *o)
5259 {
5260     if (o->op_type == OP_PADANY) {
5261         o->op_type = OP_PADAV;
5262         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5263         return o;
5264     }
5265     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5266                 && ckWARN(WARN_DEPRECATED)) {
5267         Perl_warner(aTHX_ WARN_DEPRECATED,
5268                 "Using an array as a reference is deprecated");
5269     }
5270     return newUNOP(OP_RV2AV, 0, scalar(o));
5271 }
5272
5273 OP *
5274 Perl_newGVREF(pTHX_ I32 type, OP *o)
5275 {
5276     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5277         return newUNOP(OP_NULL, 0, o);
5278     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5279 }
5280
5281 OP *
5282 Perl_newHVREF(pTHX_ OP *o)
5283 {
5284     if (o->op_type == OP_PADANY) {
5285         o->op_type = OP_PADHV;
5286         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5287         return o;
5288     }
5289     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5290                 && ckWARN(WARN_DEPRECATED)) {
5291         Perl_warner(aTHX_ WARN_DEPRECATED,
5292                 "Using a hash as a reference is deprecated");
5293     }
5294     return newUNOP(OP_RV2HV, 0, scalar(o));
5295 }
5296
5297 OP *
5298 Perl_oopsCV(pTHX_ OP *o)
5299 {
5300     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5301     /* STUB */
5302     return o;
5303 }
5304
5305 OP *
5306 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5307 {
5308     return newUNOP(OP_RV2CV, flags, scalar(o));
5309 }
5310
5311 OP *
5312 Perl_newSVREF(pTHX_ OP *o)
5313 {
5314     if (o->op_type == OP_PADANY) {
5315         o->op_type = OP_PADSV;
5316         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5317         return o;
5318     }
5319     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5320         o->op_flags |= OPpDONE_SVREF;
5321         return o;
5322     }
5323     return newUNOP(OP_RV2SV, 0, scalar(o));
5324 }
5325
5326 /* Check routines. */
5327
5328 OP *
5329 Perl_ck_anoncode(pTHX_ OP *o)
5330 {
5331     PADOFFSET ix;
5332     SV* name;
5333
5334     name = NEWSV(1106,0);
5335     sv_upgrade(name, SVt_PVNV);
5336     sv_setpvn(name, "&", 1);
5337     SvIVX(name) = -1;
5338     SvNVX(name) = 1;
5339     ix = pad_alloc(o->op_type, SVs_PADMY);
5340     av_store(PL_comppad_name, ix, name);
5341     av_store(PL_comppad, ix, cSVOPo->op_sv);
5342     SvPADMY_on(cSVOPo->op_sv);
5343     cSVOPo->op_sv = Nullsv;
5344     cSVOPo->op_targ = ix;
5345     return o;
5346 }
5347
5348 OP *
5349 Perl_ck_bitop(pTHX_ OP *o)
5350 {
5351     o->op_private = PL_hints;
5352     return o;
5353 }
5354
5355 OP *
5356 Perl_ck_concat(pTHX_ OP *o)
5357 {
5358     if (cUNOPo->op_first->op_type == OP_CONCAT)
5359         o->op_flags |= OPf_STACKED;
5360     return o;
5361 }
5362
5363 OP *
5364 Perl_ck_spair(pTHX_ OP *o)
5365 {
5366     if (o->op_flags & OPf_KIDS) {
5367         OP* newop;
5368         OP* kid;
5369         OPCODE type = o->op_type;
5370         o = modkids(ck_fun(o), type);
5371         kid = cUNOPo->op_first;
5372         newop = kUNOP->op_first->op_sibling;
5373         if (newop &&
5374             (newop->op_sibling ||
5375              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5376              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5377              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5378
5379             return o;
5380         }
5381         op_free(kUNOP->op_first);
5382         kUNOP->op_first = newop;
5383     }
5384     o->op_ppaddr = PL_ppaddr[++o->op_type];
5385     return ck_fun(o);
5386 }
5387
5388 OP *
5389 Perl_ck_delete(pTHX_ OP *o)
5390 {
5391     o = ck_fun(o);
5392     o->op_private = 0;
5393     if (o->op_flags & OPf_KIDS) {
5394         OP *kid = cUNOPo->op_first;
5395         switch (kid->op_type) {
5396         case OP_ASLICE:
5397             o->op_flags |= OPf_SPECIAL;
5398             /* FALL THROUGH */
5399         case OP_HSLICE:
5400             o->op_private |= OPpSLICE;
5401             break;
5402         case OP_AELEM:
5403             o->op_flags |= OPf_SPECIAL;
5404             /* FALL THROUGH */
5405         case OP_HELEM:
5406             break;
5407         default:
5408             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5409                   PL_op_desc[o->op_type]);
5410         }
5411         op_null(kid);
5412     }
5413     return o;
5414 }
5415
5416 OP *
5417 Perl_ck_eof(pTHX_ OP *o)
5418 {
5419     I32 type = o->op_type;
5420
5421     if (o->op_flags & OPf_KIDS) {
5422         if (cLISTOPo->op_first->op_type == OP_STUB) {
5423             op_free(o);
5424             o = newUNOP(type, OPf_SPECIAL,
5425                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5426         }
5427         return ck_fun(o);
5428     }
5429     return o;
5430 }
5431
5432 OP *
5433 Perl_ck_eval(pTHX_ OP *o)
5434 {
5435     PL_hints |= HINT_BLOCK_SCOPE;
5436     if (o->op_flags & OPf_KIDS) {
5437         SVOP *kid = (SVOP*)cUNOPo->op_first;
5438
5439         if (!kid) {
5440             o->op_flags &= ~OPf_KIDS;
5441             op_null(o);
5442         }
5443         else if (kid->op_type == OP_LINESEQ) {
5444             LOGOP *enter;
5445
5446             kid->op_next = o->op_next;
5447             cUNOPo->op_first = 0;
5448             op_free(o);
5449
5450             NewOp(1101, enter, 1, LOGOP);
5451             enter->op_type = OP_ENTERTRY;
5452             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5453             enter->op_private = 0;
5454
5455             /* establish postfix order */
5456             enter->op_next = (OP*)enter;
5457
5458             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5459             o->op_type = OP_LEAVETRY;
5460             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5461             enter->op_other = o;
5462             return o;
5463         }
5464         else
5465             scalar((OP*)kid);
5466     }
5467     else {
5468         op_free(o);
5469         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5470     }
5471     o->op_targ = (PADOFFSET)PL_hints;
5472     return o;
5473 }
5474
5475 OP *
5476 Perl_ck_exit(pTHX_ OP *o)
5477 {
5478 #ifdef VMS
5479     HV *table = GvHV(PL_hintgv);
5480     if (table) {
5481        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5482        if (svp && *svp && SvTRUE(*svp))
5483            o->op_private |= OPpEXIT_VMSISH;
5484     }
5485 #endif
5486     return ck_fun(o);
5487 }
5488
5489 OP *
5490 Perl_ck_exec(pTHX_ OP *o)
5491 {
5492     OP *kid;
5493     if (o->op_flags & OPf_STACKED) {
5494         o = ck_fun(o);
5495         kid = cUNOPo->op_first->op_sibling;
5496         if (kid->op_type == OP_RV2GV)
5497             op_null(kid);
5498     }
5499     else
5500         o = listkids(o);
5501     return o;
5502 }
5503
5504 OP *
5505 Perl_ck_exists(pTHX_ OP *o)
5506 {
5507     o = ck_fun(o);
5508     if (o->op_flags & OPf_KIDS) {
5509         OP *kid = cUNOPo->op_first;
5510         if (kid->op_type == OP_ENTERSUB) {
5511             (void) ref(kid, o->op_type);
5512             if (kid->op_type != OP_RV2CV && !PL_error_count)
5513                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5514                            PL_op_desc[o->op_type]);
5515             o->op_private |= OPpEXISTS_SUB;
5516         }
5517         else if (kid->op_type == OP_AELEM)
5518             o->op_flags |= OPf_SPECIAL;
5519         else if (kid->op_type != OP_HELEM)
5520             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5521                        PL_op_desc[o->op_type]);
5522         op_null(kid);
5523     }
5524     return o;
5525 }
5526
5527 #if 0
5528 OP *
5529 Perl_ck_gvconst(pTHX_ register OP *o)
5530 {
5531     o = fold_constants(o);
5532     if (o->op_type == OP_CONST)
5533         o->op_type = OP_GV;
5534     return o;
5535 }
5536 #endif
5537
5538 OP *
5539 Perl_ck_rvconst(pTHX_ register OP *o)
5540 {
5541     SVOP *kid = (SVOP*)cUNOPo->op_first;
5542
5543     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5544     if (kid->op_type == OP_CONST) {
5545         char *name;
5546         int iscv;
5547         GV *gv;
5548         SV *kidsv = kid->op_sv;
5549         STRLEN n_a;
5550
5551         /* Is it a constant from cv_const_sv()? */
5552         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5553             SV *rsv = SvRV(kidsv);
5554             int svtype = SvTYPE(rsv);
5555             char *badtype = Nullch;
5556
5557             switch (o->op_type) {
5558             case OP_RV2SV:
5559                 if (svtype > SVt_PVMG)
5560                     badtype = "a SCALAR";
5561                 break;
5562             case OP_RV2AV:
5563                 if (svtype != SVt_PVAV)
5564                     badtype = "an ARRAY";
5565                 break;
5566             case OP_RV2HV:
5567                 if (svtype != SVt_PVHV) {
5568                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5569                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5570                         if (ksv && SvROK(*ksv)
5571                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5572                         {
5573                                 break;
5574                         }
5575                     }
5576                     badtype = "a HASH";
5577                 }
5578                 break;
5579             case OP_RV2CV:
5580                 if (svtype != SVt_PVCV)
5581                     badtype = "a CODE";
5582                 break;
5583             }
5584             if (badtype)
5585                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5586             return o;
5587         }
5588         name = SvPV(kidsv, n_a);
5589         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5590             char *badthing = Nullch;
5591             switch (o->op_type) {
5592             case OP_RV2SV:
5593                 badthing = "a SCALAR";
5594                 break;
5595             case OP_RV2AV:
5596                 badthing = "an ARRAY";
5597                 break;
5598             case OP_RV2HV:
5599                 badthing = "a HASH";
5600                 break;
5601             }
5602             if (badthing)
5603                 Perl_croak(aTHX_
5604           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5605                       name, badthing);
5606         }
5607         /*
5608          * This is a little tricky.  We only want to add the symbol if we
5609          * didn't add it in the lexer.  Otherwise we get duplicate strict
5610          * warnings.  But if we didn't add it in the lexer, we must at
5611          * least pretend like we wanted to add it even if it existed before,
5612          * or we get possible typo warnings.  OPpCONST_ENTERED says
5613          * whether the lexer already added THIS instance of this symbol.
5614          */
5615         iscv = (o->op_type == OP_RV2CV) * 2;
5616         do {
5617             gv = gv_fetchpv(name,
5618                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5619                 iscv
5620                     ? SVt_PVCV
5621                     : o->op_type == OP_RV2SV
5622                         ? SVt_PV
5623                         : o->op_type == OP_RV2AV
5624                             ? SVt_PVAV
5625                             : o->op_type == OP_RV2HV
5626                                 ? SVt_PVHV
5627                                 : SVt_PVGV);
5628         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5629         if (gv) {
5630             kid->op_type = OP_GV;
5631             SvREFCNT_dec(kid->op_sv);
5632 #ifdef USE_ITHREADS
5633             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5634             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5635             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5636             GvIN_PAD_on(gv);
5637             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5638 #else
5639             kid->op_sv = SvREFCNT_inc(gv);
5640 #endif
5641             kid->op_private = 0;
5642             kid->op_ppaddr = PL_ppaddr[OP_GV];
5643         }
5644     }
5645     return o;
5646 }
5647
5648 OP *
5649 Perl_ck_ftst(pTHX_ OP *o)
5650 {
5651     I32 type = o->op_type;
5652
5653     if (o->op_flags & OPf_REF) {
5654         /* nothing */
5655     }
5656     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5657         SVOP *kid = (SVOP*)cUNOPo->op_first;
5658
5659         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5660             STRLEN n_a;
5661             OP *newop = newGVOP(type, OPf_REF,
5662                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5663             op_free(o);
5664             o = newop;
5665         }
5666     }
5667     else {
5668         op_free(o);
5669         if (type == OP_FTTTY)
5670            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5671                                 SVt_PVIO));
5672         else
5673             o = newUNOP(type, 0, newDEFSVOP());
5674     }
5675     return o;
5676 }
5677
5678 OP *
5679 Perl_ck_fun(pTHX_ OP *o)
5680 {
5681     register OP *kid;
5682     OP **tokid;
5683     OP *sibl;
5684     I32 numargs = 0;
5685     int type = o->op_type;
5686     register I32 oa = PL_opargs[type] >> OASHIFT;
5687
5688     if (o->op_flags & OPf_STACKED) {
5689         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5690             oa &= ~OA_OPTIONAL;
5691         else
5692             return no_fh_allowed(o);
5693     }
5694
5695     if (o->op_flags & OPf_KIDS) {
5696         STRLEN n_a;
5697         tokid = &cLISTOPo->op_first;
5698         kid = cLISTOPo->op_first;
5699         if (kid->op_type == OP_PUSHMARK ||
5700             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5701         {
5702             tokid = &kid->op_sibling;
5703             kid = kid->op_sibling;
5704         }
5705         if (!kid && PL_opargs[type] & OA_DEFGV)
5706             *tokid = kid = newDEFSVOP();
5707
5708         while (oa && kid) {
5709             numargs++;
5710             sibl = kid->op_sibling;
5711             switch (oa & 7) {
5712             case OA_SCALAR:
5713                 /* list seen where single (scalar) arg expected? */
5714                 if (numargs == 1 && !(oa >> 4)
5715                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5716                 {
5717                     return too_many_arguments(o,PL_op_desc[type]);
5718                 }
5719                 scalar(kid);
5720                 break;
5721             case OA_LIST:
5722                 if (oa < 16) {
5723                     kid = 0;
5724                     continue;
5725                 }
5726                 else
5727                     list(kid);
5728                 break;
5729             case OA_AVREF:
5730                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5731                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5732                     Perl_warner(aTHX_ WARN_SYNTAX,
5733                         "Useless use of %s with no values",
5734                         PL_op_desc[type]);
5735
5736                 if (kid->op_type == OP_CONST &&
5737                     (kid->op_private & OPpCONST_BARE))
5738                 {
5739                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5740                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5741                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5742                     if (ckWARN(WARN_DEPRECATED))
5743                         Perl_warner(aTHX_ WARN_DEPRECATED,
5744                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5745                             name, (IV)numargs, PL_op_desc[type]);
5746                     op_free(kid);
5747                     kid = newop;
5748                     kid->op_sibling = sibl;
5749                     *tokid = kid;
5750                 }
5751                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5752                     bad_type(numargs, "array", PL_op_desc[type], kid);
5753                 mod(kid, type);
5754                 break;
5755             case OA_HVREF:
5756                 if (kid->op_type == OP_CONST &&
5757                     (kid->op_private & OPpCONST_BARE))
5758                 {
5759                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5760                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5761                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5762                     if (ckWARN(WARN_DEPRECATED))
5763                         Perl_warner(aTHX_ WARN_DEPRECATED,
5764                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5765                             name, (IV)numargs, PL_op_desc[type]);
5766                     op_free(kid);
5767                     kid = newop;
5768                     kid->op_sibling = sibl;
5769                     *tokid = kid;
5770                 }
5771                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5772                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5773                 mod(kid, type);
5774                 break;
5775             case OA_CVREF:
5776                 {
5777                     OP *newop = newUNOP(OP_NULL, 0, kid);
5778                     kid->op_sibling = 0;
5779                     linklist(kid);
5780                     newop->op_next = newop;
5781                     kid = newop;
5782                     kid->op_sibling = sibl;
5783                     *tokid = kid;
5784                 }
5785                 break;
5786             case OA_FILEREF:
5787                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5788                     if (kid->op_type == OP_CONST &&
5789                         (kid->op_private & OPpCONST_BARE))
5790                     {
5791                         OP *newop = newGVOP(OP_GV, 0,
5792                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5793                                         SVt_PVIO) );
5794                         op_free(kid);
5795                         kid = newop;
5796                     }
5797                     else if (kid->op_type == OP_READLINE) {
5798                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5799                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5800                     }
5801                     else {
5802                         I32 flags = OPf_SPECIAL;
5803                         I32 priv = 0;
5804                         PADOFFSET targ = 0;
5805
5806                         /* is this op a FH constructor? */
5807                         if (is_handle_constructor(o,numargs)) {
5808                             char *name = Nullch;
5809                             STRLEN len;
5810
5811                             flags = 0;
5812                             /* Set a flag to tell rv2gv to vivify
5813                              * need to "prove" flag does not mean something
5814                              * else already - NI-S 1999/05/07
5815                              */
5816                             priv = OPpDEREF;
5817                             if (kid->op_type == OP_PADSV) {
5818                                 SV **namep = av_fetch(PL_comppad_name,
5819                                                       kid->op_targ, 4);
5820                                 if (namep && *namep)
5821                                     name = SvPV(*namep, len);
5822                             }
5823                             else if (kid->op_type == OP_RV2SV
5824                                      && kUNOP->op_first->op_type == OP_GV)
5825                             {
5826                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5827                                 name = GvNAME(gv);
5828                                 len = GvNAMELEN(gv);
5829                             }
5830                             else if (kid->op_type == OP_AELEM
5831                                      || kid->op_type == OP_HELEM)
5832                             {
5833                                 name = "__ANONIO__";
5834                                 len = 10;
5835                                 mod(kid,type);
5836                             }
5837                             if (name) {
5838                                 SV *namesv;
5839                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5840                                 namesv = PL_curpad[targ];
5841                                 (void)SvUPGRADE(namesv, SVt_PV);
5842                                 if (*name != '$')
5843                                     sv_setpvn(namesv, "$", 1);
5844                                 sv_catpvn(namesv, name, len);
5845                             }
5846                         }
5847                         kid->op_sibling = 0;
5848                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5849                         kid->op_targ = targ;
5850                         kid->op_private |= priv;
5851                     }
5852                     kid->op_sibling = sibl;
5853                     *tokid = kid;
5854                 }
5855                 scalar(kid);
5856                 break;
5857             case OA_SCALARREF:
5858                 mod(scalar(kid), type);
5859                 break;
5860             }
5861             oa >>= 4;
5862             tokid = &kid->op_sibling;
5863             kid = kid->op_sibling;
5864         }
5865         o->op_private |= numargs;
5866         if (kid)
5867             return too_many_arguments(o,PL_op_desc[o->op_type]);
5868         listkids(o);
5869     }
5870     else if (PL_opargs[type] & OA_DEFGV) {
5871         op_free(o);
5872         return newUNOP(type, 0, newDEFSVOP());
5873     }
5874
5875     if (oa) {
5876         while (oa & OA_OPTIONAL)
5877             oa >>= 4;
5878         if (oa && oa != OA_LIST)
5879             return too_few_arguments(o,PL_op_desc[o->op_type]);
5880     }
5881     return o;
5882 }
5883
5884 OP *
5885 Perl_ck_glob(pTHX_ OP *o)
5886 {
5887     GV *gv;
5888
5889     o = ck_fun(o);
5890     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5891         append_elem(OP_GLOB, o, newDEFSVOP());
5892
5893     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5894         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5895
5896 #if !defined(PERL_EXTERNAL_GLOB)
5897     /* XXX this can be tightened up and made more failsafe. */
5898     if (!gv) {
5899         GV *glob_gv;
5900         ENTER;
5901         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5902                          Nullsv, Nullsv);
5903         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5904         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5905         GvCV(gv) = GvCV(glob_gv);
5906         SvREFCNT_inc((SV*)GvCV(gv));
5907         GvIMPORTED_CV_on(gv);
5908         LEAVE;
5909     }
5910 #endif /* PERL_EXTERNAL_GLOB */
5911
5912     if (gv && GvIMPORTED_CV(gv)) {
5913         append_elem(OP_GLOB, o,
5914                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5915         o->op_type = OP_LIST;
5916         o->op_ppaddr = PL_ppaddr[OP_LIST];
5917         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5918         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5919         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5920                     append_elem(OP_LIST, o,
5921                                 scalar(newUNOP(OP_RV2CV, 0,
5922                                                newGVOP(OP_GV, 0, gv)))));
5923         o = newUNOP(OP_NULL, 0, ck_subr(o));
5924         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5925         return o;
5926     }
5927     gv = newGVgen("main");
5928     gv_IOadd(gv);
5929     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5930     scalarkids(o);
5931     return o;
5932 }
5933
5934 OP *
5935 Perl_ck_grep(pTHX_ OP *o)
5936 {
5937     LOGOP *gwop;
5938     OP *kid;
5939     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5940
5941     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5942     NewOp(1101, gwop, 1, LOGOP);
5943
5944     if (o->op_flags & OPf_STACKED) {
5945         OP* k;
5946         o = ck_sort(o);
5947         kid = cLISTOPo->op_first->op_sibling;
5948         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5949             kid = k;
5950         }
5951         kid->op_next = (OP*)gwop;
5952         o->op_flags &= ~OPf_STACKED;
5953     }
5954     kid = cLISTOPo->op_first->op_sibling;
5955     if (type == OP_MAPWHILE)
5956         list(kid);
5957     else
5958         scalar(kid);
5959     o = ck_fun(o);
5960     if (PL_error_count)
5961         return o;
5962     kid = cLISTOPo->op_first->op_sibling;
5963     if (kid->op_type != OP_NULL)
5964         Perl_croak(aTHX_ "panic: ck_grep");
5965     kid = kUNOP->op_first;
5966
5967     gwop->op_type = type;
5968     gwop->op_ppaddr = PL_ppaddr[type];
5969     gwop->op_first = listkids(o);
5970     gwop->op_flags |= OPf_KIDS;
5971     gwop->op_private = 1;
5972     gwop->op_other = LINKLIST(kid);
5973     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5974     kid->op_next = (OP*)gwop;
5975
5976     kid = cLISTOPo->op_first->op_sibling;
5977     if (!kid || !kid->op_sibling)
5978         return too_few_arguments(o,PL_op_desc[o->op_type]);
5979     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5980         mod(kid, OP_GREPSTART);
5981
5982     return (OP*)gwop;
5983 }
5984
5985 OP *
5986 Perl_ck_index(pTHX_ OP *o)
5987 {
5988     if (o->op_flags & OPf_KIDS) {
5989         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5990         if (kid)
5991             kid = kid->op_sibling;                      /* get past "big" */
5992         if (kid && kid->op_type == OP_CONST)
5993             fbm_compile(((SVOP*)kid)->op_sv, 0);
5994     }
5995     return ck_fun(o);
5996 }
5997
5998 OP *
5999 Perl_ck_lengthconst(pTHX_ OP *o)
6000 {
6001     /* XXX length optimization goes here */
6002     return ck_fun(o);
6003 }
6004
6005 OP *
6006 Perl_ck_lfun(pTHX_ OP *o)
6007 {
6008     OPCODE type = o->op_type;
6009     return modkids(ck_fun(o), type);
6010 }
6011
6012 OP *
6013 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6014 {
6015     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6016         switch (cUNOPo->op_first->op_type) {
6017         case OP_RV2AV:
6018             /* This is needed for
6019                if (defined %stash::)
6020                to work.   Do not break Tk.
6021                */
6022             break;                      /* Globals via GV can be undef */
6023         case OP_PADAV:
6024         case OP_AASSIGN:                /* Is this a good idea? */
6025             Perl_warner(aTHX_ WARN_DEPRECATED,
6026                         "defined(@array) is deprecated");
6027             Perl_warner(aTHX_ WARN_DEPRECATED,
6028                         "\t(Maybe you should just omit the defined()?)\n");
6029         break;
6030         case OP_RV2HV:
6031             /* This is needed for
6032                if (defined %stash::)
6033                to work.   Do not break Tk.
6034                */
6035             break;                      /* Globals via GV can be undef */
6036         case OP_PADHV:
6037             Perl_warner(aTHX_ WARN_DEPRECATED,
6038                         "defined(%%hash) is deprecated");
6039             Perl_warner(aTHX_ WARN_DEPRECATED,
6040                         "\t(Maybe you should just omit the defined()?)\n");
6041             break;
6042         default:
6043             /* no warning */
6044             break;
6045         }
6046     }
6047     return ck_rfun(o);
6048 }
6049
6050 OP *
6051 Perl_ck_rfun(pTHX_ OP *o)
6052 {
6053     OPCODE type = o->op_type;
6054     return refkids(ck_fun(o), type);
6055 }
6056
6057 OP *
6058 Perl_ck_listiob(pTHX_ OP *o)
6059 {
6060     register OP *kid;
6061
6062     kid = cLISTOPo->op_first;
6063     if (!kid) {
6064         o = force_list(o);
6065         kid = cLISTOPo->op_first;
6066     }
6067     if (kid->op_type == OP_PUSHMARK)
6068         kid = kid->op_sibling;
6069     if (kid && o->op_flags & OPf_STACKED)
6070         kid = kid->op_sibling;
6071     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6072         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6073             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6074             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6075             cLISTOPo->op_first->op_sibling = kid;
6076             cLISTOPo->op_last = kid;
6077             kid = kid->op_sibling;
6078         }
6079     }
6080
6081     if (!kid)
6082         append_elem(o->op_type, o, newDEFSVOP());
6083
6084     return listkids(o);
6085 }
6086
6087 OP *
6088 Perl_ck_sassign(pTHX_ OP *o)
6089 {
6090     OP *kid = cLISTOPo->op_first;
6091     /* has a disposable target? */
6092     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6093         && !(kid->op_flags & OPf_STACKED)
6094         /* Cannot steal the second time! */
6095         && !(kid->op_private & OPpTARGET_MY))
6096     {
6097         OP *kkid = kid->op_sibling;
6098
6099         /* Can just relocate the target. */
6100         if (kkid && kkid->op_type == OP_PADSV
6101             && !(kkid->op_private & OPpLVAL_INTRO))
6102         {
6103             kid->op_targ = kkid->op_targ;
6104             kkid->op_targ = 0;
6105             /* Now we do not need PADSV and SASSIGN. */
6106             kid->op_sibling = o->op_sibling;    /* NULL */
6107             cLISTOPo->op_first = NULL;
6108             op_free(o);
6109             op_free(kkid);
6110             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6111             return kid;
6112         }
6113     }
6114     return o;
6115 }
6116
6117 OP *
6118 Perl_ck_match(pTHX_ OP *o)
6119 {
6120     o->op_private |= OPpRUNTIME;
6121     return o;
6122 }
6123
6124 OP *
6125 Perl_ck_method(pTHX_ OP *o)
6126 {
6127     OP *kid = cUNOPo->op_first;
6128     if (kid->op_type == OP_CONST) {
6129         SV* sv = kSVOP->op_sv;
6130         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6131             OP *cmop;
6132             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6133                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6134             }
6135             else {
6136                 kSVOP->op_sv = Nullsv;
6137             }
6138             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6139             op_free(o);
6140             return cmop;
6141         }
6142     }
6143     return o;
6144 }
6145
6146 OP *
6147 Perl_ck_null(pTHX_ OP *o)
6148 {
6149     return o;
6150 }
6151
6152 OP *
6153 Perl_ck_open(pTHX_ OP *o)
6154 {
6155     HV *table = GvHV(PL_hintgv);
6156     if (table) {
6157         SV **svp;
6158         I32 mode;
6159         svp = hv_fetch(table, "open_IN", 7, FALSE);
6160         if (svp && *svp) {
6161             mode = mode_from_discipline(*svp);
6162             if (mode & O_BINARY)
6163                 o->op_private |= OPpOPEN_IN_RAW;
6164             else if (mode & O_TEXT)
6165                 o->op_private |= OPpOPEN_IN_CRLF;
6166         }
6167
6168         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6169         if (svp && *svp) {
6170             mode = mode_from_discipline(*svp);
6171             if (mode & O_BINARY)
6172                 o->op_private |= OPpOPEN_OUT_RAW;
6173             else if (mode & O_TEXT)
6174                 o->op_private |= OPpOPEN_OUT_CRLF;
6175         }
6176     }
6177     if (o->op_type == OP_BACKTICK)
6178         return o;
6179     return ck_fun(o);
6180 }
6181
6182 OP *
6183 Perl_ck_repeat(pTHX_ OP *o)
6184 {
6185     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6186         o->op_private |= OPpREPEAT_DOLIST;
6187         cBINOPo->op_first = force_list(cBINOPo->op_first);
6188     }
6189     else
6190         scalar(o);
6191     return o;
6192 }
6193
6194 OP *
6195 Perl_ck_require(pTHX_ OP *o)
6196 {
6197     GV* gv;
6198
6199     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6200         SVOP *kid = (SVOP*)cUNOPo->op_first;
6201
6202         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6203             char *s;
6204             for (s = SvPVX(kid->op_sv); *s; s++) {
6205                 if (*s == ':' && s[1] == ':') {
6206                     *s = '/';
6207                     Move(s+2, s+1, strlen(s+2)+1, char);
6208                     --SvCUR(kid->op_sv);
6209                 }
6210             }
6211             if (SvREADONLY(kid->op_sv)) {
6212                 SvREADONLY_off(kid->op_sv);
6213                 sv_catpvn(kid->op_sv, ".pm", 3);
6214                 SvREADONLY_on(kid->op_sv);
6215             }
6216             else
6217                 sv_catpvn(kid->op_sv, ".pm", 3);
6218         }
6219     }
6220
6221     /* handle override, if any */
6222     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6223     if (!(gv && GvIMPORTED_CV(gv)))
6224         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6225
6226     if (gv && GvIMPORTED_CV(gv)) {
6227         OP *kid = cUNOPo->op_first;
6228         cUNOPo->op_first = 0;
6229         op_free(o);
6230         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6231                                append_elem(OP_LIST, kid,
6232                                            scalar(newUNOP(OP_RV2CV, 0,
6233                                                           newGVOP(OP_GV, 0,
6234                                                                   gv))))));
6235     }
6236
6237     return ck_fun(o);
6238 }
6239
6240 OP *
6241 Perl_ck_return(pTHX_ OP *o)
6242 {
6243     OP *kid;
6244     if (CvLVALUE(PL_compcv)) {
6245         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6246             mod(kid, OP_LEAVESUBLV);
6247     }
6248     return o;
6249 }
6250
6251 #if 0
6252 OP *
6253 Perl_ck_retarget(pTHX_ OP *o)
6254 {
6255     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6256     /* STUB */
6257     return o;
6258 }
6259 #endif
6260
6261 OP *
6262 Perl_ck_select(pTHX_ OP *o)
6263 {
6264     OP* kid;
6265     if (o->op_flags & OPf_KIDS) {
6266         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6267         if (kid && kid->op_sibling) {
6268             o->op_type = OP_SSELECT;
6269             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6270             o = ck_fun(o);
6271             return fold_constants(o);
6272         }
6273     }
6274     o = ck_fun(o);
6275     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6276     if (kid && kid->op_type == OP_RV2GV)
6277         kid->op_private &= ~HINT_STRICT_REFS;
6278     return o;
6279 }
6280
6281 OP *
6282 Perl_ck_shift(pTHX_ OP *o)
6283 {
6284     I32 type = o->op_type;
6285
6286     if (!(o->op_flags & OPf_KIDS)) {
6287         OP *argop;
6288
6289         op_free(o);
6290 #ifdef USE_THREADS
6291         if (!CvUNIQUE(PL_compcv)) {
6292             argop = newOP(OP_PADAV, OPf_REF);
6293             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6294         }
6295         else {
6296             argop = newUNOP(OP_RV2AV, 0,
6297                 scalar(newGVOP(OP_GV, 0,
6298                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6299         }
6300 #else
6301         argop = newUNOP(OP_RV2AV, 0,
6302             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6303                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6304 #endif /* USE_THREADS */
6305         return newUNOP(type, 0, scalar(argop));
6306     }
6307     return scalar(modkids(ck_fun(o), type));
6308 }
6309
6310 OP *
6311 Perl_ck_sort(pTHX_ OP *o)
6312 {
6313     OP *firstkid;
6314
6315     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6316         simplify_sort(o);
6317     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6318     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6319         OP *k = NULL;
6320         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6321
6322         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6323             linklist(kid);
6324             if (kid->op_type == OP_SCOPE) {
6325                 k = kid->op_next;
6326                 kid->op_next = 0;
6327             }
6328             else if (kid->op_type == OP_LEAVE) {
6329                 if (o->op_type == OP_SORT) {
6330                     op_null(kid);                       /* wipe out leave */
6331                     kid->op_next = kid;
6332
6333                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6334                         if (k->op_next == kid)
6335                             k->op_next = 0;
6336                         /* don't descend into loops */
6337                         else if (k->op_type == OP_ENTERLOOP
6338                                  || k->op_type == OP_ENTERITER)
6339                         {
6340                             k = cLOOPx(k)->op_lastop;
6341                         }
6342                     }
6343                 }
6344                 else
6345                     kid->op_next = 0;           /* just disconnect the leave */
6346                 k = kLISTOP->op_first;
6347             }
6348             CALL_PEEP(k);
6349
6350             kid = firstkid;
6351             if (o->op_type == OP_SORT) {
6352                 /* provide scalar context for comparison function/block */
6353                 kid = scalar(kid);
6354                 kid->op_next = kid;
6355             }
6356             else
6357                 kid->op_next = k;
6358             o->op_flags |= OPf_SPECIAL;
6359         }
6360         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6361             op_null(firstkid);
6362
6363         firstkid = firstkid->op_sibling;
6364     }
6365
6366     /* provide list context for arguments */
6367     if (o->op_type == OP_SORT)
6368         list(firstkid);
6369
6370     return o;
6371 }
6372
6373 STATIC void
6374 S_simplify_sort(pTHX_ OP *o)
6375 {
6376     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6377     OP *k;
6378     int reversed;
6379     GV *gv;
6380     if (!(o->op_flags & OPf_STACKED))
6381         return;
6382     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6383     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6384     kid = kUNOP->op_first;                              /* get past null */
6385     if (kid->op_type != OP_SCOPE)
6386         return;
6387     kid = kLISTOP->op_last;                             /* get past scope */
6388     switch(kid->op_type) {
6389         case OP_NCMP:
6390         case OP_I_NCMP:
6391         case OP_SCMP:
6392             break;
6393         default:
6394             return;
6395     }
6396     k = kid;                                            /* remember this node*/
6397     if (kBINOP->op_first->op_type != OP_RV2SV)
6398         return;
6399     kid = kBINOP->op_first;                             /* get past cmp */
6400     if (kUNOP->op_first->op_type != OP_GV)
6401         return;
6402     kid = kUNOP->op_first;                              /* get past rv2sv */
6403     gv = kGVOP_gv;
6404     if (GvSTASH(gv) != PL_curstash)
6405         return;
6406     if (strEQ(GvNAME(gv), "a"))
6407         reversed = 0;
6408     else if (strEQ(GvNAME(gv), "b"))
6409         reversed = 1;
6410     else
6411         return;
6412     kid = k;                                            /* back to cmp */
6413     if (kBINOP->op_last->op_type != OP_RV2SV)
6414         return;
6415     kid = kBINOP->op_last;                              /* down to 2nd arg */
6416     if (kUNOP->op_first->op_type != OP_GV)
6417         return;
6418     kid = kUNOP->op_first;                              /* get past rv2sv */
6419     gv = kGVOP_gv;
6420     if (GvSTASH(gv) != PL_curstash
6421         || ( reversed
6422             ? strNE(GvNAME(gv), "a")
6423             : strNE(GvNAME(gv), "b")))
6424         return;
6425     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6426     if (reversed)
6427         o->op_private |= OPpSORT_REVERSE;
6428     if (k->op_type == OP_NCMP)
6429         o->op_private |= OPpSORT_NUMERIC;
6430     if (k->op_type == OP_I_NCMP)
6431         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6432     kid = cLISTOPo->op_first->op_sibling;
6433     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6434     op_free(kid);                                     /* then delete it */
6435 }
6436
6437 OP *
6438 Perl_ck_split(pTHX_ OP *o)
6439 {
6440     register OP *kid;
6441
6442     if (o->op_flags & OPf_STACKED)
6443         return no_fh_allowed(o);
6444
6445     kid = cLISTOPo->op_first;
6446     if (kid->op_type != OP_NULL)
6447         Perl_croak(aTHX_ "panic: ck_split");
6448     kid = kid->op_sibling;
6449     op_free(cLISTOPo->op_first);
6450     cLISTOPo->op_first = kid;
6451     if (!kid) {
6452         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6453         cLISTOPo->op_last = kid; /* There was only one element previously */
6454     }
6455
6456     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6457         OP *sibl = kid->op_sibling;
6458         kid->op_sibling = 0;
6459         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6460         if (cLISTOPo->op_first == cLISTOPo->op_last)
6461             cLISTOPo->op_last = kid;
6462         cLISTOPo->op_first = kid;
6463         kid->op_sibling = sibl;
6464     }
6465
6466     kid->op_type = OP_PUSHRE;
6467     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6468     scalar(kid);
6469
6470     if (!kid->op_sibling)
6471         append_elem(OP_SPLIT, o, newDEFSVOP());
6472
6473     kid = kid->op_sibling;
6474     scalar(kid);
6475
6476     if (!kid->op_sibling)
6477         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6478
6479     kid = kid->op_sibling;
6480     scalar(kid);
6481
6482     if (kid->op_sibling)
6483         return too_many_arguments(o,PL_op_desc[o->op_type]);
6484
6485     return o;
6486 }
6487
6488 OP *
6489 Perl_ck_join(pTHX_ OP *o)
6490 {
6491     if (ckWARN(WARN_SYNTAX)) {
6492         OP *kid = cLISTOPo->op_first->op_sibling;
6493         if (kid && kid->op_type == OP_MATCH) {
6494             char *pmstr = "STRING";
6495             if (PM_GETRE(kPMOP))
6496                 pmstr = PM_GETRE(kPMOP)->precomp;
6497             Perl_warner(aTHX_ WARN_SYNTAX,
6498                         "/%s/ should probably be written as \"%s\"",
6499                         pmstr, pmstr);
6500         }
6501     }
6502     return ck_fun(o);
6503 }
6504
6505 OP *
6506 Perl_ck_subr(pTHX_ OP *o)
6507 {
6508     OP *prev = ((cUNOPo->op_first->op_sibling)
6509              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6510     OP *o2 = prev->op_sibling;
6511     OP *cvop;
6512     char *proto = 0;
6513     CV *cv = 0;
6514     GV *namegv = 0;
6515     int optional = 0;
6516     I32 arg = 0;
6517     STRLEN n_a;
6518
6519     o->op_private |= OPpENTERSUB_HASTARG;
6520     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6521     if (cvop->op_type == OP_RV2CV) {
6522         SVOP* tmpop;
6523         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6524         op_null(cvop);          /* disable rv2cv */
6525         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6526         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6527             GV *gv = cGVOPx_gv(tmpop);
6528             cv = GvCVu(gv);
6529             if (!cv)
6530                 tmpop->op_private |= OPpEARLY_CV;
6531             else if (SvPOK(cv)) {
6532                 namegv = CvANON(cv) ? gv : CvGV(cv);
6533                 proto = SvPV((SV*)cv, n_a);
6534             }
6535         }
6536     }
6537     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6538         if (o2->op_type == OP_CONST)
6539             o2->op_private &= ~OPpCONST_STRICT;
6540         else if (o2->op_type == OP_LIST) {
6541             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6542             if (o && o->op_type == OP_CONST)
6543                 o->op_private &= ~OPpCONST_STRICT;
6544         }
6545     }
6546     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6547     if (PERLDB_SUB && PL_curstash != PL_debstash)
6548         o->op_private |= OPpENTERSUB_DB;
6549     while (o2 != cvop) {
6550         if (proto) {
6551             switch (*proto) {
6552             case '\0':
6553                 return too_many_arguments(o, gv_ename(namegv));
6554             case ';':
6555                 optional = 1;
6556                 proto++;
6557                 continue;
6558             case '$':
6559                 proto++;
6560                 arg++;
6561                 scalar(o2);
6562                 break;
6563             case '%':
6564             case '@':
6565                 list(o2);
6566                 arg++;
6567                 break;
6568             case '&':
6569                 proto++;
6570                 arg++;
6571                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6572                     bad_type(arg,
6573                         arg == 1 ? "block or sub {}" : "sub {}",
6574                         gv_ename(namegv), o2);
6575                 break;
6576             case '*':
6577                 /* '*' allows any scalar type, including bareword */
6578                 proto++;
6579                 arg++;
6580                 if (o2->op_type == OP_RV2GV)
6581                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6582                 else if (o2->op_type == OP_CONST)
6583                     o2->op_private &= ~OPpCONST_STRICT;
6584                 else if (o2->op_type == OP_ENTERSUB) {
6585                     /* accidental subroutine, revert to bareword */
6586                     OP *gvop = ((UNOP*)o2)->op_first;
6587                     if (gvop && gvop->op_type == OP_NULL) {
6588                         gvop = ((UNOP*)gvop)->op_first;
6589                         if (gvop) {
6590                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6591                                 ;
6592                             if (gvop &&
6593                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6594                                 (gvop = ((UNOP*)gvop)->op_first) &&
6595                                 gvop->op_type == OP_GV)
6596                             {
6597                                 GV *gv = cGVOPx_gv(gvop);
6598                                 OP *sibling = o2->op_sibling;
6599                                 SV *n = newSVpvn("",0);
6600                                 op_free(o2);
6601                                 gv_fullname3(n, gv, "");
6602                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6603                                     sv_chop(n, SvPVX(n)+6);
6604                                 o2 = newSVOP(OP_CONST, 0, n);
6605                                 prev->op_sibling = o2;
6606                                 o2->op_sibling = sibling;
6607                             }
6608                         }
6609                     }
6610                 }
6611                 scalar(o2);
6612                 break;
6613             case '\\':
6614                 proto++;
6615                 arg++;
6616                 switch (*proto++) {
6617                 case '*':
6618                     if (o2->op_type != OP_RV2GV)
6619                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6620                     goto wrapref;
6621                 case '&':
6622                     if (o2->op_type != OP_ENTERSUB)
6623                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6624                     goto wrapref;
6625                 case '$':
6626                     if (o2->op_type != OP_RV2SV
6627                         && o2->op_type != OP_PADSV
6628                         && o2->op_type != OP_HELEM
6629                         && o2->op_type != OP_AELEM
6630                         && o2->op_type != OP_THREADSV)
6631                     {
6632                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6633                     }
6634                     goto wrapref;
6635                 case '@':
6636                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6637                         bad_type(arg, "array", gv_ename(namegv), o2);
6638                     goto wrapref;
6639                 case '%':
6640                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6641                         bad_type(arg, "hash", gv_ename(namegv), o2);
6642                   wrapref:
6643                     {
6644                         OP* kid = o2;
6645                         OP* sib = kid->op_sibling;
6646                         kid->op_sibling = 0;
6647                         o2 = newUNOP(OP_REFGEN, 0, kid);
6648                         o2->op_sibling = sib;
6649                         prev->op_sibling = o2;
6650                     }
6651                     break;
6652                 default: goto oops;
6653                 }
6654                 break;
6655             case ' ':
6656                 proto++;
6657                 continue;
6658             default:
6659               oops:
6660                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6661                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6662             }
6663         }
6664         else
6665             list(o2);
6666         mod(o2, OP_ENTERSUB);
6667         prev = o2;
6668         o2 = o2->op_sibling;
6669     }
6670     if (proto && !optional &&
6671           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6672         return too_few_arguments(o, gv_ename(namegv));
6673     return o;
6674 }
6675
6676 OP *
6677 Perl_ck_svconst(pTHX_ OP *o)
6678 {
6679     SvREADONLY_on(cSVOPo->op_sv);
6680     return o;
6681 }
6682
6683 OP *
6684 Perl_ck_trunc(pTHX_ OP *o)
6685 {
6686     if (o->op_flags & OPf_KIDS) {
6687         SVOP *kid = (SVOP*)cUNOPo->op_first;
6688
6689         if (kid->op_type == OP_NULL)
6690             kid = (SVOP*)kid->op_sibling;
6691         if (kid && kid->op_type == OP_CONST &&
6692             (kid->op_private & OPpCONST_BARE))
6693         {
6694             o->op_flags |= OPf_SPECIAL;
6695             kid->op_private &= ~OPpCONST_STRICT;
6696         }
6697     }
6698     return ck_fun(o);
6699 }
6700
6701 OP *
6702 Perl_ck_substr(pTHX_ OP *o)
6703 {
6704     o = ck_fun(o);
6705     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6706         OP *kid = cLISTOPo->op_first;
6707
6708         if (kid->op_type == OP_NULL)
6709             kid = kid->op_sibling;
6710         if (kid)
6711             kid->op_flags |= OPf_MOD;
6712
6713     }
6714     return o;
6715 }
6716
6717 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6718
6719 void
6720 Perl_peep(pTHX_ register OP *o)
6721 {
6722     register OP* oldop = 0;
6723     STRLEN n_a;
6724
6725     if (!o || o->op_seq)
6726         return;
6727     ENTER;
6728     SAVEOP();
6729     SAVEVPTR(PL_curcop);
6730     for (; o; o = o->op_next) {
6731         if (o->op_seq)
6732             break;
6733         if (!PL_op_seqmax)
6734             PL_op_seqmax++;
6735         PL_op = o;
6736         switch (o->op_type) {
6737         case OP_SETSTATE:
6738         case OP_NEXTSTATE:
6739         case OP_DBSTATE:
6740             PL_curcop = ((COP*)o);              /* for warnings */
6741             o->op_seq = PL_op_seqmax++;
6742             break;
6743
6744         case OP_CONST:
6745             if (cSVOPo->op_private & OPpCONST_STRICT)
6746                 no_bareword_allowed(o);
6747 #ifdef USE_ITHREADS
6748             /* Relocate sv to the pad for thread safety.
6749              * Despite being a "constant", the SV is written to,
6750              * for reference counts, sv_upgrade() etc. */
6751             if (cSVOP->op_sv) {
6752                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6753                 if (SvPADTMP(cSVOPo->op_sv)) {
6754                     /* If op_sv is already a PADTMP then it is being used by
6755                      * some pad, so make a copy. */
6756                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6757                     SvREADONLY_on(PL_curpad[ix]);
6758                     SvREFCNT_dec(cSVOPo->op_sv);
6759                 }
6760                 else {
6761                     SvREFCNT_dec(PL_curpad[ix]);
6762                     SvPADTMP_on(cSVOPo->op_sv);
6763                     PL_curpad[ix] = cSVOPo->op_sv;
6764                     /* XXX I don't know how this isn't readonly already. */
6765                     SvREADONLY_on(PL_curpad[ix]);
6766                 }
6767                 cSVOPo->op_sv = Nullsv;
6768                 o->op_targ = ix;
6769             }
6770 #endif
6771             o->op_seq = PL_op_seqmax++;
6772             break;
6773
6774         case OP_CONCAT:
6775             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6776                 if (o->op_next->op_private & OPpTARGET_MY) {
6777                     if (o->op_flags & OPf_STACKED) /* chained concats */
6778                         goto ignore_optimization;
6779                     else {
6780                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6781                         o->op_targ = o->op_next->op_targ;
6782                         o->op_next->op_targ = 0;
6783                         o->op_private |= OPpTARGET_MY;
6784                     }
6785                 }
6786                 op_null(o->op_next);
6787             }
6788           ignore_optimization:
6789             o->op_seq = PL_op_seqmax++;
6790             break;
6791         case OP_STUB:
6792             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6793                 o->op_seq = PL_op_seqmax++;
6794                 break; /* Scalar stub must produce undef.  List stub is noop */
6795             }
6796             goto nothin;
6797         case OP_NULL:
6798             if (o->op_targ == OP_NEXTSTATE
6799                 || o->op_targ == OP_DBSTATE
6800                 || o->op_targ == OP_SETSTATE)
6801             {
6802                 PL_curcop = ((COP*)o);
6803             }
6804             /* XXX: We avoid setting op_seq here to prevent later calls
6805                to peep() from mistakenly concluding that optimisation
6806                has already occurred. This doesn't fix the real problem,
6807                though (See 20010220.007). AMS 20010719 */
6808             if (oldop && o->op_next) {
6809                 oldop->op_next = o->op_next;
6810                 continue;
6811             }
6812             break;
6813         case OP_SCALAR:
6814         case OP_LINESEQ:
6815         case OP_SCOPE:
6816           nothin:
6817             if (oldop && o->op_next) {
6818                 oldop->op_next = o->op_next;
6819                 continue;
6820             }
6821             o->op_seq = PL_op_seqmax++;
6822             break;
6823
6824         case OP_GV:
6825             if (o->op_next->op_type == OP_RV2SV) {
6826                 if (!(o->op_next->op_private & OPpDEREF)) {
6827                     op_null(o->op_next);
6828                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6829                                                                | OPpOUR_INTRO);
6830                     o->op_next = o->op_next->op_next;
6831                     o->op_type = OP_GVSV;
6832                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6833                 }
6834             }
6835             else if (o->op_next->op_type == OP_RV2AV) {
6836                 OP* pop = o->op_next->op_next;
6837                 IV i;
6838                 if (pop->op_type == OP_CONST &&
6839                     (PL_op = pop->op_next) &&
6840                     pop->op_next->op_type == OP_AELEM &&
6841                     !(pop->op_next->op_private &
6842                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6843                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6844                                 <= 255 &&
6845                     i >= 0)
6846                 {
6847                     GV *gv;
6848                     op_null(o->op_next);
6849                     op_null(pop->op_next);
6850                     op_null(pop);
6851                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6852                     o->op_next = pop->op_next->op_next;
6853                     o->op_type = OP_AELEMFAST;
6854                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6855                     o->op_private = (U8)i;
6856                     gv = cGVOPo_gv;
6857                     GvAVn(gv);
6858                 }
6859             }
6860             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6861                 GV *gv = cGVOPo_gv;
6862                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6863                     /* XXX could check prototype here instead of just carping */
6864                     SV *sv = sv_newmortal();
6865                     gv_efullname3(sv, gv, Nullch);
6866                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6867                                 "%s() called too early to check prototype",
6868                                 SvPV_nolen(sv));
6869                 }
6870             }
6871
6872             o->op_seq = PL_op_seqmax++;
6873             break;
6874
6875         case OP_MAPWHILE:
6876         case OP_GREPWHILE:
6877         case OP_AND:
6878         case OP_OR:
6879         case OP_ANDASSIGN:
6880         case OP_ORASSIGN:
6881         case OP_COND_EXPR:
6882         case OP_RANGE:
6883             o->op_seq = PL_op_seqmax++;
6884             while (cLOGOP->op_other->op_type == OP_NULL)
6885                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6886             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6887             break;
6888
6889         case OP_ENTERLOOP:
6890         case OP_ENTERITER:
6891             o->op_seq = PL_op_seqmax++;
6892             while (cLOOP->op_redoop->op_type == OP_NULL)
6893                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6894             peep(cLOOP->op_redoop);
6895             while (cLOOP->op_nextop->op_type == OP_NULL)
6896                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6897             peep(cLOOP->op_nextop);
6898             while (cLOOP->op_lastop->op_type == OP_NULL)
6899                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6900             peep(cLOOP->op_lastop);
6901             break;
6902
6903         case OP_QR:
6904         case OP_MATCH:
6905         case OP_SUBST:
6906             o->op_seq = PL_op_seqmax++;
6907             while (cPMOP->op_pmreplstart &&
6908                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6909                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6910             peep(cPMOP->op_pmreplstart);
6911             break;
6912
6913         case OP_EXEC:
6914             o->op_seq = PL_op_seqmax++;
6915             if (ckWARN(WARN_SYNTAX) && o->op_next
6916                 && o->op_next->op_type == OP_NEXTSTATE) {
6917                 if (o->op_next->op_sibling &&
6918                         o->op_next->op_sibling->op_type != OP_EXIT &&
6919                         o->op_next->op_sibling->op_type != OP_WARN &&
6920                         o->op_next->op_sibling->op_type != OP_DIE) {
6921                     line_t oldline = CopLINE(PL_curcop);
6922
6923                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6924                     Perl_warner(aTHX_ WARN_EXEC,
6925                                 "Statement unlikely to be reached");
6926                     Perl_warner(aTHX_ WARN_EXEC,
6927                                 "\t(Maybe you meant system() when you said exec()?)\n");
6928                     CopLINE_set(PL_curcop, oldline);
6929                 }
6930             }
6931             break;
6932
6933         case OP_HELEM: {
6934             UNOP *rop;
6935             SV *lexname;
6936             GV **fields;
6937             SV **svp, **indsvp, *sv;
6938             I32 ind;
6939             char *key = NULL;
6940             STRLEN keylen;
6941
6942             o->op_seq = PL_op_seqmax++;
6943
6944             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6945                 break;
6946
6947             /* Make the CONST have a shared SV */
6948             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6949             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6950                 key = SvPV(sv, keylen);
6951                 lexname = newSVpvn_share(key,
6952                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6953                                          0);
6954                 SvREFCNT_dec(sv);
6955                 *svp = lexname;
6956             }
6957
6958             if ((o->op_private & (OPpLVAL_INTRO)))
6959                 break;
6960
6961             rop = (UNOP*)((BINOP*)o)->op_first;
6962             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6963                 break;
6964             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6965             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6966                 break;
6967             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6968             if (!fields || !GvHV(*fields))
6969                 break;
6970             key = SvPV(*svp, keylen);
6971             indsvp = hv_fetch(GvHV(*fields), key,
6972                               SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6973             if (!indsvp) {
6974                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6975                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6976             }
6977             ind = SvIV(*indsvp);
6978             if (ind < 1)
6979                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6980             rop->op_type = OP_RV2AV;
6981             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6982             o->op_type = OP_AELEM;
6983             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6984             sv = newSViv(ind);
6985             if (SvREADONLY(*svp))
6986                 SvREADONLY_on(sv);
6987             SvFLAGS(sv) |= (SvFLAGS(*svp)
6988                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6989             SvREFCNT_dec(*svp);
6990             *svp = sv;
6991             break;
6992         }
6993
6994         case OP_HSLICE: {
6995             UNOP *rop;
6996             SV *lexname;
6997             GV **fields;
6998             SV **svp, **indsvp, *sv;
6999             I32 ind;
7000             char *key;
7001             STRLEN keylen;
7002             SVOP *first_key_op, *key_op;
7003
7004             o->op_seq = PL_op_seqmax++;
7005             if ((o->op_private & (OPpLVAL_INTRO))
7006                 /* I bet there's always a pushmark... */
7007                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7008                 /* hmmm, no optimization if list contains only one key. */
7009                 break;
7010             rop = (UNOP*)((LISTOP*)o)->op_last;
7011             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7012                 break;
7013             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7014             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7015                 break;
7016             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7017             if (!fields || !GvHV(*fields))
7018                 break;
7019             /* Again guessing that the pushmark can be jumped over.... */
7020             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7021                 ->op_first->op_sibling;
7022             /* Check that the key list contains only constants. */
7023             for (key_op = first_key_op; key_op;
7024                  key_op = (SVOP*)key_op->op_sibling)
7025                 if (key_op->op_type != OP_CONST)
7026                     break;
7027             if (key_op)
7028                 break;
7029             rop->op_type = OP_RV2AV;
7030             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7031             o->op_type = OP_ASLICE;
7032             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7033             for (key_op = first_key_op; key_op;
7034                  key_op = (SVOP*)key_op->op_sibling) {
7035                 svp = cSVOPx_svp(key_op);
7036                 key = SvPV(*svp, keylen);
7037                 indsvp = hv_fetch(GvHV(*fields), key,
7038                                   SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7039                 if (!indsvp) {
7040                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7041                                "in variable %s of type %s",
7042                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7043                 }
7044                 ind = SvIV(*indsvp);
7045                 if (ind < 1)
7046                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7047                 sv = newSViv(ind);
7048                 if (SvREADONLY(*svp))
7049                     SvREADONLY_on(sv);
7050                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7051                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7052                 SvREFCNT_dec(*svp);
7053                 *svp = sv;
7054             }
7055             break;
7056         }
7057
7058         default:
7059             o->op_seq = PL_op_seqmax++;
7060             break;
7061         }
7062         oldop = o;
7063     }
7064     LEAVE;
7065 }
7066
7067 #include "XSUB.h"
7068
7069 /* Efficient sub that returns a constant scalar value. */
7070 static void
7071 const_sv_xsub(pTHXo_ CV* cv)
7072 {
7073     dXSARGS;
7074     if (items != 0) {
7075 #if 0
7076         Perl_croak(aTHX_ "usage: %s::%s()",
7077                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7078 #endif
7079     }
7080     EXTEND(sp, 1);
7081     ST(0) = (SV*)XSANY.any_ptr;
7082     XSRETURN(1);
7083 }
7084