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