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                         op_free(kid);
5940                         kid = newop;
5941                     }
5942                     else if (kid->op_type == OP_READLINE) {
5943                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5944                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5945                     }
5946                     else {
5947                         I32 flags = OPf_SPECIAL;
5948                         I32 priv = 0;
5949                         PADOFFSET targ = 0;
5950
5951                         /* is this op a FH constructor? */
5952                         if (is_handle_constructor(o,numargs)) {
5953                             char *name = Nullch;
5954                             STRLEN len;
5955
5956                             flags = 0;
5957                             /* Set a flag to tell rv2gv to vivify
5958                              * need to "prove" flag does not mean something
5959                              * else already - NI-S 1999/05/07
5960                              */
5961                             priv = OPpDEREF;
5962                             if (kid->op_type == OP_PADSV) {
5963                                 SV **namep = av_fetch(PL_comppad_name,
5964                                                       kid->op_targ, 4);
5965                                 if (namep && *namep)
5966                                     name = SvPV(*namep, len);
5967                             }
5968                             else if (kid->op_type == OP_RV2SV
5969                                      && kUNOP->op_first->op_type == OP_GV)
5970                             {
5971                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5972                                 name = GvNAME(gv);
5973                                 len = GvNAMELEN(gv);
5974                             }
5975                             else if (kid->op_type == OP_AELEM
5976                                      || kid->op_type == OP_HELEM)
5977                             {
5978                                 name = "__ANONIO__";
5979                                 len = 10;
5980                                 mod(kid,type);
5981                             }
5982                             if (name) {
5983                                 SV *namesv;
5984                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5985                                 namesv = PL_curpad[targ];
5986                                 (void)SvUPGRADE(namesv, SVt_PV);
5987                                 if (*name != '$')
5988                                     sv_setpvn(namesv, "$", 1);
5989                                 sv_catpvn(namesv, name, len);
5990                             }
5991                         }
5992                         kid->op_sibling = 0;
5993                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5994                         kid->op_targ = targ;
5995                         kid->op_private |= priv;
5996                     }
5997                     kid->op_sibling = sibl;
5998                     *tokid = kid;
5999                 }
6000                 scalar(kid);
6001                 break;
6002             case OA_SCALARREF:
6003                 mod(scalar(kid), type);
6004                 break;
6005             }
6006             oa >>= 4;
6007             tokid = &kid->op_sibling;
6008             kid = kid->op_sibling;
6009         }
6010         o->op_private |= numargs;
6011         if (kid)
6012             return too_many_arguments(o,OP_DESC(o));
6013         listkids(o);
6014     }
6015     else if (PL_opargs[type] & OA_DEFGV) {
6016         op_free(o);
6017         return newUNOP(type, 0, newDEFSVOP());
6018     }
6019
6020     if (oa) {
6021         while (oa & OA_OPTIONAL)
6022             oa >>= 4;
6023         if (oa && oa != OA_LIST)
6024             return too_few_arguments(o,OP_DESC(o));
6025     }
6026     return o;
6027 }
6028
6029 OP *
6030 Perl_ck_glob(pTHX_ OP *o)
6031 {
6032     GV *gv;
6033
6034     o = ck_fun(o);
6035     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6036         append_elem(OP_GLOB, o, newDEFSVOP());
6037
6038     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6039           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6040     {
6041         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6042     }
6043
6044 #if !defined(PERL_EXTERNAL_GLOB)
6045     /* XXX this can be tightened up and made more failsafe. */
6046     if (!gv) {
6047         GV *glob_gv;
6048         ENTER;
6049         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6050                          Nullsv, Nullsv);
6051         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6052         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6053         GvCV(gv) = GvCV(glob_gv);
6054         SvREFCNT_inc((SV*)GvCV(gv));
6055         GvIMPORTED_CV_on(gv);
6056         LEAVE;
6057     }
6058 #endif /* PERL_EXTERNAL_GLOB */
6059
6060     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6061         append_elem(OP_GLOB, o,
6062                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6063         o->op_type = OP_LIST;
6064         o->op_ppaddr = PL_ppaddr[OP_LIST];
6065         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6066         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6067         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6068                     append_elem(OP_LIST, o,
6069                                 scalar(newUNOP(OP_RV2CV, 0,
6070                                                newGVOP(OP_GV, 0, gv)))));
6071         o = newUNOP(OP_NULL, 0, ck_subr(o));
6072         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6073         return o;
6074     }
6075     gv = newGVgen("main");
6076     gv_IOadd(gv);
6077     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6078     scalarkids(o);
6079     return o;
6080 }
6081
6082 OP *
6083 Perl_ck_grep(pTHX_ OP *o)
6084 {
6085     LOGOP *gwop;
6086     OP *kid;
6087     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6088
6089     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6090     NewOp(1101, gwop, 1, LOGOP);
6091
6092     if (o->op_flags & OPf_STACKED) {
6093         OP* k;
6094         o = ck_sort(o);
6095         kid = cLISTOPo->op_first->op_sibling;
6096         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6097             kid = k;
6098         }
6099         kid->op_next = (OP*)gwop;
6100         o->op_flags &= ~OPf_STACKED;
6101     }
6102     kid = cLISTOPo->op_first->op_sibling;
6103     if (type == OP_MAPWHILE)
6104         list(kid);
6105     else
6106         scalar(kid);
6107     o = ck_fun(o);
6108     if (PL_error_count)
6109         return o;
6110     kid = cLISTOPo->op_first->op_sibling;
6111     if (kid->op_type != OP_NULL)
6112         Perl_croak(aTHX_ "panic: ck_grep");
6113     kid = kUNOP->op_first;
6114
6115     gwop->op_type = type;
6116     gwop->op_ppaddr = PL_ppaddr[type];
6117     gwop->op_first = listkids(o);
6118     gwop->op_flags |= OPf_KIDS;
6119     gwop->op_private = 1;
6120     gwop->op_other = LINKLIST(kid);
6121     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6122     kid->op_next = (OP*)gwop;
6123
6124     kid = cLISTOPo->op_first->op_sibling;
6125     if (!kid || !kid->op_sibling)
6126         return too_few_arguments(o,OP_DESC(o));
6127     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6128         mod(kid, OP_GREPSTART);
6129
6130     return (OP*)gwop;
6131 }
6132
6133 OP *
6134 Perl_ck_index(pTHX_ OP *o)
6135 {
6136     if (o->op_flags & OPf_KIDS) {
6137         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6138         if (kid)
6139             kid = kid->op_sibling;                      /* get past "big" */
6140         if (kid && kid->op_type == OP_CONST)
6141             fbm_compile(((SVOP*)kid)->op_sv, 0);
6142     }
6143     return ck_fun(o);
6144 }
6145
6146 OP *
6147 Perl_ck_lengthconst(pTHX_ OP *o)
6148 {
6149     /* XXX length optimization goes here */
6150     return ck_fun(o);
6151 }
6152
6153 OP *
6154 Perl_ck_lfun(pTHX_ OP *o)
6155 {
6156     OPCODE type = o->op_type;
6157     return modkids(ck_fun(o), type);
6158 }
6159
6160 OP *
6161 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6162 {
6163     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6164         switch (cUNOPo->op_first->op_type) {
6165         case OP_RV2AV:
6166             /* This is needed for
6167                if (defined %stash::)
6168                to work.   Do not break Tk.
6169                */
6170             break;                      /* Globals via GV can be undef */
6171         case OP_PADAV:
6172         case OP_AASSIGN:                /* Is this a good idea? */
6173             Perl_warner(aTHX_ WARN_DEPRECATED,
6174                         "defined(@array) is deprecated");
6175             Perl_warner(aTHX_ WARN_DEPRECATED,
6176                         "\t(Maybe you should just omit the defined()?)\n");
6177         break;
6178         case OP_RV2HV:
6179             /* This is needed for
6180                if (defined %stash::)
6181                to work.   Do not break Tk.
6182                */
6183             break;                      /* Globals via GV can be undef */
6184         case OP_PADHV:
6185             Perl_warner(aTHX_ WARN_DEPRECATED,
6186                         "defined(%%hash) is deprecated");
6187             Perl_warner(aTHX_ WARN_DEPRECATED,
6188                         "\t(Maybe you should just omit the defined()?)\n");
6189             break;
6190         default:
6191             /* no warning */
6192             break;
6193         }
6194     }
6195     return ck_rfun(o);
6196 }
6197
6198 OP *
6199 Perl_ck_rfun(pTHX_ OP *o)
6200 {
6201     OPCODE type = o->op_type;
6202     return refkids(ck_fun(o), type);
6203 }
6204
6205 OP *
6206 Perl_ck_listiob(pTHX_ OP *o)
6207 {
6208     register OP *kid;
6209
6210     kid = cLISTOPo->op_first;
6211     if (!kid) {
6212         o = force_list(o);
6213         kid = cLISTOPo->op_first;
6214     }
6215     if (kid->op_type == OP_PUSHMARK)
6216         kid = kid->op_sibling;
6217     if (kid && o->op_flags & OPf_STACKED)
6218         kid = kid->op_sibling;
6219     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6220         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6221             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6222             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6223             cLISTOPo->op_first->op_sibling = kid;
6224             cLISTOPo->op_last = kid;
6225             kid = kid->op_sibling;
6226         }
6227     }
6228
6229     if (!kid)
6230         append_elem(o->op_type, o, newDEFSVOP());
6231
6232     return listkids(o);
6233 }
6234
6235 OP *
6236 Perl_ck_sassign(pTHX_ OP *o)
6237 {
6238     OP *kid = cLISTOPo->op_first;
6239     /* has a disposable target? */
6240     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6241         && !(kid->op_flags & OPf_STACKED)
6242         /* Cannot steal the second time! */
6243         && !(kid->op_private & OPpTARGET_MY))
6244     {
6245         OP *kkid = kid->op_sibling;
6246
6247         /* Can just relocate the target. */
6248         if (kkid && kkid->op_type == OP_PADSV
6249             && !(kkid->op_private & OPpLVAL_INTRO))
6250         {
6251             kid->op_targ = kkid->op_targ;
6252             kkid->op_targ = 0;
6253             /* Now we do not need PADSV and SASSIGN. */
6254             kid->op_sibling = o->op_sibling;    /* NULL */
6255             cLISTOPo->op_first = NULL;
6256             op_free(o);
6257             op_free(kkid);
6258             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6259             return kid;
6260         }
6261     }
6262     return o;
6263 }
6264
6265 OP *
6266 Perl_ck_match(pTHX_ OP *o)
6267 {
6268     o->op_private |= OPpRUNTIME;
6269     return o;
6270 }
6271
6272 OP *
6273 Perl_ck_method(pTHX_ OP *o)
6274 {
6275     OP *kid = cUNOPo->op_first;
6276     if (kid->op_type == OP_CONST) {
6277         SV* sv = kSVOP->op_sv;
6278         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6279             OP *cmop;
6280             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6281                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6282             }
6283             else {
6284                 kSVOP->op_sv = Nullsv;
6285             }
6286             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6287             op_free(o);
6288             return cmop;
6289         }
6290     }
6291     return o;
6292 }
6293
6294 OP *
6295 Perl_ck_null(pTHX_ OP *o)
6296 {
6297     return o;
6298 }
6299
6300 OP *
6301 Perl_ck_open(pTHX_ OP *o)
6302 {
6303     HV *table = GvHV(PL_hintgv);
6304     if (table) {
6305         SV **svp;
6306         I32 mode;
6307         svp = hv_fetch(table, "open_IN", 7, FALSE);
6308         if (svp && *svp) {
6309             mode = mode_from_discipline(*svp);
6310             if (mode & O_BINARY)
6311                 o->op_private |= OPpOPEN_IN_RAW;
6312             else if (mode & O_TEXT)
6313                 o->op_private |= OPpOPEN_IN_CRLF;
6314         }
6315
6316         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6317         if (svp && *svp) {
6318             mode = mode_from_discipline(*svp);
6319             if (mode & O_BINARY)
6320                 o->op_private |= OPpOPEN_OUT_RAW;
6321             else if (mode & O_TEXT)
6322                 o->op_private |= OPpOPEN_OUT_CRLF;
6323         }
6324     }
6325     if (o->op_type == OP_BACKTICK)
6326         return o;
6327     return ck_fun(o);
6328 }
6329
6330 OP *
6331 Perl_ck_repeat(pTHX_ OP *o)
6332 {
6333     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6334         o->op_private |= OPpREPEAT_DOLIST;
6335         cBINOPo->op_first = force_list(cBINOPo->op_first);
6336     }
6337     else
6338         scalar(o);
6339     return o;
6340 }
6341
6342 OP *
6343 Perl_ck_require(pTHX_ OP *o)
6344 {
6345     GV* gv;
6346
6347     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6348         SVOP *kid = (SVOP*)cUNOPo->op_first;
6349
6350         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6351             char *s;
6352             for (s = SvPVX(kid->op_sv); *s; s++) {
6353                 if (*s == ':' && s[1] == ':') {
6354                     *s = '/';
6355                     Move(s+2, s+1, strlen(s+2)+1, char);
6356                     --SvCUR(kid->op_sv);
6357                 }
6358             }
6359             if (SvREADONLY(kid->op_sv)) {
6360                 SvREADONLY_off(kid->op_sv);
6361                 sv_catpvn(kid->op_sv, ".pm", 3);
6362                 SvREADONLY_on(kid->op_sv);
6363             }
6364             else
6365                 sv_catpvn(kid->op_sv, ".pm", 3);
6366         }
6367     }
6368
6369     /* handle override, if any */
6370     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6371     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6372         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6373
6374     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6375         OP *kid = cUNOPo->op_first;
6376         cUNOPo->op_first = 0;
6377         op_free(o);
6378         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6379                                append_elem(OP_LIST, kid,
6380                                            scalar(newUNOP(OP_RV2CV, 0,
6381                                                           newGVOP(OP_GV, 0,
6382                                                                   gv))))));
6383     }
6384
6385     return ck_fun(o);
6386 }
6387
6388 OP *
6389 Perl_ck_return(pTHX_ OP *o)
6390 {
6391     OP *kid;
6392     if (CvLVALUE(PL_compcv)) {
6393         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6394             mod(kid, OP_LEAVESUBLV);
6395     }
6396     return o;
6397 }
6398
6399 #if 0
6400 OP *
6401 Perl_ck_retarget(pTHX_ OP *o)
6402 {
6403     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6404     /* STUB */
6405     return o;
6406 }
6407 #endif
6408
6409 OP *
6410 Perl_ck_select(pTHX_ OP *o)
6411 {
6412     OP* kid;
6413     if (o->op_flags & OPf_KIDS) {
6414         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6415         if (kid && kid->op_sibling) {
6416             o->op_type = OP_SSELECT;
6417             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6418             o = ck_fun(o);
6419             return fold_constants(o);
6420         }
6421     }
6422     o = ck_fun(o);
6423     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6424     if (kid && kid->op_type == OP_RV2GV)
6425         kid->op_private &= ~HINT_STRICT_REFS;
6426     return o;
6427 }
6428
6429 OP *
6430 Perl_ck_shift(pTHX_ OP *o)
6431 {
6432     I32 type = o->op_type;
6433
6434     if (!(o->op_flags & OPf_KIDS)) {
6435         OP *argop;
6436
6437         op_free(o);
6438 #ifdef USE_5005THREADS
6439         if (!CvUNIQUE(PL_compcv)) {
6440             argop = newOP(OP_PADAV, OPf_REF);
6441             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6442         }
6443         else {
6444             argop = newUNOP(OP_RV2AV, 0,
6445                 scalar(newGVOP(OP_GV, 0,
6446                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6447         }
6448 #else
6449         argop = newUNOP(OP_RV2AV, 0,
6450             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6451                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6452 #endif /* USE_5005THREADS */
6453         return newUNOP(type, 0, scalar(argop));
6454     }
6455     return scalar(modkids(ck_fun(o), type));
6456 }
6457
6458 OP *
6459 Perl_ck_sort(pTHX_ OP *o)
6460 {
6461     OP *firstkid;
6462
6463     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6464         simplify_sort(o);
6465     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6466     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6467         OP *k = NULL;
6468         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6469
6470         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6471             linklist(kid);
6472             if (kid->op_type == OP_SCOPE) {
6473                 k = kid->op_next;
6474                 kid->op_next = 0;
6475             }
6476             else if (kid->op_type == OP_LEAVE) {
6477                 if (o->op_type == OP_SORT) {
6478                     op_null(kid);                       /* wipe out leave */
6479                     kid->op_next = kid;
6480
6481                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6482                         if (k->op_next == kid)
6483                             k->op_next = 0;
6484                         /* don't descend into loops */
6485                         else if (k->op_type == OP_ENTERLOOP
6486                                  || k->op_type == OP_ENTERITER)
6487                         {
6488                             k = cLOOPx(k)->op_lastop;
6489                         }
6490                     }
6491                 }
6492                 else
6493                     kid->op_next = 0;           /* just disconnect the leave */
6494                 k = kLISTOP->op_first;
6495             }
6496             CALL_PEEP(k);
6497
6498             kid = firstkid;
6499             if (o->op_type == OP_SORT) {
6500                 /* provide scalar context for comparison function/block */
6501                 kid = scalar(kid);
6502                 kid->op_next = kid;
6503             }
6504             else
6505                 kid->op_next = k;
6506             o->op_flags |= OPf_SPECIAL;
6507         }
6508         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6509             op_null(firstkid);
6510
6511         firstkid = firstkid->op_sibling;
6512     }
6513
6514     /* provide list context for arguments */
6515     if (o->op_type == OP_SORT)
6516         list(firstkid);
6517
6518     return o;
6519 }
6520
6521 STATIC void
6522 S_simplify_sort(pTHX_ OP *o)
6523 {
6524     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6525     OP *k;
6526     int reversed;
6527     GV *gv;
6528     if (!(o->op_flags & OPf_STACKED))
6529         return;
6530     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6531     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6532     kid = kUNOP->op_first;                              /* get past null */
6533     if (kid->op_type != OP_SCOPE)
6534         return;
6535     kid = kLISTOP->op_last;                             /* get past scope */
6536     switch(kid->op_type) {
6537         case OP_NCMP:
6538         case OP_I_NCMP:
6539         case OP_SCMP:
6540             break;
6541         default:
6542             return;
6543     }
6544     k = kid;                                            /* remember this node*/
6545     if (kBINOP->op_first->op_type != OP_RV2SV)
6546         return;
6547     kid = kBINOP->op_first;                             /* get past cmp */
6548     if (kUNOP->op_first->op_type != OP_GV)
6549         return;
6550     kid = kUNOP->op_first;                              /* get past rv2sv */
6551     gv = kGVOP_gv;
6552     if (GvSTASH(gv) != PL_curstash)
6553         return;
6554     if (strEQ(GvNAME(gv), "a"))
6555         reversed = 0;
6556     else if (strEQ(GvNAME(gv), "b"))
6557         reversed = 1;
6558     else
6559         return;
6560     kid = k;                                            /* back to cmp */
6561     if (kBINOP->op_last->op_type != OP_RV2SV)
6562         return;
6563     kid = kBINOP->op_last;                              /* down to 2nd arg */
6564     if (kUNOP->op_first->op_type != OP_GV)
6565         return;
6566     kid = kUNOP->op_first;                              /* get past rv2sv */
6567     gv = kGVOP_gv;
6568     if (GvSTASH(gv) != PL_curstash
6569         || ( reversed
6570             ? strNE(GvNAME(gv), "a")
6571             : strNE(GvNAME(gv), "b")))
6572         return;
6573     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6574     if (reversed)
6575         o->op_private |= OPpSORT_REVERSE;
6576     if (k->op_type == OP_NCMP)
6577         o->op_private |= OPpSORT_NUMERIC;
6578     if (k->op_type == OP_I_NCMP)
6579         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6580     kid = cLISTOPo->op_first->op_sibling;
6581     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6582     op_free(kid);                                     /* then delete it */
6583 }
6584
6585 OP *
6586 Perl_ck_split(pTHX_ OP *o)
6587 {
6588     register OP *kid;
6589
6590     if (o->op_flags & OPf_STACKED)
6591         return no_fh_allowed(o);
6592
6593     kid = cLISTOPo->op_first;
6594     if (kid->op_type != OP_NULL)
6595         Perl_croak(aTHX_ "panic: ck_split");
6596     kid = kid->op_sibling;
6597     op_free(cLISTOPo->op_first);
6598     cLISTOPo->op_first = kid;
6599     if (!kid) {
6600         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6601         cLISTOPo->op_last = kid; /* There was only one element previously */
6602     }
6603
6604     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6605         OP *sibl = kid->op_sibling;
6606         kid->op_sibling = 0;
6607         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6608         if (cLISTOPo->op_first == cLISTOPo->op_last)
6609             cLISTOPo->op_last = kid;
6610         cLISTOPo->op_first = kid;
6611         kid->op_sibling = sibl;
6612     }
6613
6614     kid->op_type = OP_PUSHRE;
6615     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6616     scalar(kid);
6617
6618     if (!kid->op_sibling)
6619         append_elem(OP_SPLIT, o, newDEFSVOP());
6620
6621     kid = kid->op_sibling;
6622     scalar(kid);
6623
6624     if (!kid->op_sibling)
6625         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6626
6627     kid = kid->op_sibling;
6628     scalar(kid);
6629
6630     if (kid->op_sibling)
6631         return too_many_arguments(o,OP_DESC(o));
6632
6633     return o;
6634 }
6635
6636 OP *
6637 Perl_ck_join(pTHX_ OP *o)
6638 {
6639     if (ckWARN(WARN_SYNTAX)) {
6640         OP *kid = cLISTOPo->op_first->op_sibling;
6641         if (kid && kid->op_type == OP_MATCH) {
6642             char *pmstr = "STRING";
6643             if (PM_GETRE(kPMOP))
6644                 pmstr = PM_GETRE(kPMOP)->precomp;
6645             Perl_warner(aTHX_ WARN_SYNTAX,
6646                         "/%s/ should probably be written as \"%s\"",
6647                         pmstr, pmstr);
6648         }
6649     }
6650     return ck_fun(o);
6651 }
6652
6653 OP *
6654 Perl_ck_subr(pTHX_ OP *o)
6655 {
6656     OP *prev = ((cUNOPo->op_first->op_sibling)
6657              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6658     OP *o2 = prev->op_sibling;
6659     OP *cvop;
6660     char *proto = 0;
6661     CV *cv = 0;
6662     GV *namegv = 0;
6663     int optional = 0;
6664     I32 arg = 0;
6665     I32 contextclass = 0;
6666     char *e = 0;
6667     STRLEN n_a;
6668
6669     o->op_private |= OPpENTERSUB_HASTARG;
6670     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6671     if (cvop->op_type == OP_RV2CV) {
6672         SVOP* tmpop;
6673         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6674         op_null(cvop);          /* disable rv2cv */
6675         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6676         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6677             GV *gv = cGVOPx_gv(tmpop);
6678             cv = GvCVu(gv);
6679             if (!cv)
6680                 tmpop->op_private |= OPpEARLY_CV;
6681             else if (SvPOK(cv)) {
6682                 namegv = CvANON(cv) ? gv : CvGV(cv);
6683                 proto = SvPV((SV*)cv, n_a);
6684             }
6685         }
6686     }
6687     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6688         if (o2->op_type == OP_CONST)
6689             o2->op_private &= ~OPpCONST_STRICT;
6690         else if (o2->op_type == OP_LIST) {
6691             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6692             if (o && o->op_type == OP_CONST)
6693                 o->op_private &= ~OPpCONST_STRICT;
6694         }
6695     }
6696     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6697     if (PERLDB_SUB && PL_curstash != PL_debstash)
6698         o->op_private |= OPpENTERSUB_DB;
6699     while (o2 != cvop) {
6700         if (proto) {
6701             switch (*proto) {
6702             case '\0':
6703                 return too_many_arguments(o, gv_ename(namegv));
6704             case ';':
6705                 optional = 1;
6706                 proto++;
6707                 continue;
6708             case '$':
6709                 proto++;
6710                 arg++;
6711                 scalar(o2);
6712                 break;
6713             case '%':
6714             case '@':
6715                 list(o2);
6716                 arg++;
6717                 break;
6718             case '&':
6719                 proto++;
6720                 arg++;
6721                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6722                     bad_type(arg,
6723                         arg == 1 ? "block or sub {}" : "sub {}",
6724                         gv_ename(namegv), o2);
6725                 break;
6726             case '*':
6727                 /* '*' allows any scalar type, including bareword */
6728                 proto++;
6729                 arg++;
6730                 if (o2->op_type == OP_RV2GV)
6731                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6732                 else if (o2->op_type == OP_CONST)
6733                     o2->op_private &= ~OPpCONST_STRICT;
6734                 else if (o2->op_type == OP_ENTERSUB) {
6735                     /* accidental subroutine, revert to bareword */
6736                     OP *gvop = ((UNOP*)o2)->op_first;
6737                     if (gvop && gvop->op_type == OP_NULL) {
6738                         gvop = ((UNOP*)gvop)->op_first;
6739                         if (gvop) {
6740                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6741                                 ;
6742                             if (gvop &&
6743                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6744                                 (gvop = ((UNOP*)gvop)->op_first) &&
6745                                 gvop->op_type == OP_GV)
6746                             {
6747                                 GV *gv = cGVOPx_gv(gvop);
6748                                 OP *sibling = o2->op_sibling;
6749                                 SV *n = newSVpvn("",0);
6750                                 op_free(o2);
6751                                 gv_fullname3(n, gv, "");
6752                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6753                                     sv_chop(n, SvPVX(n)+6);
6754                                 o2 = newSVOP(OP_CONST, 0, n);
6755                                 prev->op_sibling = o2;
6756                                 o2->op_sibling = sibling;
6757                             }
6758                         }
6759                     }
6760                 }
6761                 scalar(o2);
6762                 break;
6763             case '[': case ']':
6764                  goto oops;
6765                  break;
6766             case '\\':
6767                 proto++;
6768                 arg++;
6769             again:
6770                 switch (*proto++) {
6771                 case '[':
6772                      if (contextclass++ == 0) {
6773                           e = strchr(proto, ']');
6774                           if (!e || e == proto)
6775                                goto oops;
6776                      }
6777                      else
6778                           goto oops;
6779                      goto again;
6780                      break;
6781                 case ']':
6782                      if (contextclass)
6783                           contextclass = 0;
6784                      else
6785                           goto oops;
6786                      break;
6787                 case '*':
6788                      if (o2->op_type == OP_RV2GV)
6789                           goto wrapref;
6790                      if (!contextclass)
6791                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6792                      break;
6793                 case '&':
6794                      if (o2->op_type == OP_ENTERSUB)
6795                           goto wrapref;
6796                      if (!contextclass)
6797                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6798                      break;
6799                 case '$':
6800                     if (o2->op_type == OP_RV2SV ||
6801                         o2->op_type == OP_PADSV ||
6802                         o2->op_type == OP_HELEM ||
6803                         o2->op_type == OP_AELEM ||
6804                         o2->op_type == OP_THREADSV)
6805                          goto wrapref;
6806                     if (!contextclass)
6807                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6808                      break;
6809                 case '@':
6810                     if (o2->op_type == OP_RV2AV ||
6811                         o2->op_type == OP_PADAV)
6812                          goto wrapref;
6813                     if (!contextclass)
6814                         bad_type(arg, "array", gv_ename(namegv), o2);
6815                     break;
6816                 case '%':
6817                     if (o2->op_type == OP_RV2HV ||
6818                         o2->op_type == OP_PADHV)
6819                          goto wrapref;
6820                     if (!contextclass)
6821                          bad_type(arg, "hash", gv_ename(namegv), o2);
6822                     break;
6823                 wrapref:
6824                     {
6825                         OP* kid = o2;
6826                         OP* sib = kid->op_sibling;
6827                         kid->op_sibling = 0;
6828                         o2 = newUNOP(OP_REFGEN, 0, kid);
6829                         o2->op_sibling = sib;
6830                         prev->op_sibling = o2;
6831                     }
6832                     if (contextclass && e) {
6833                          proto = e + 1;
6834                          contextclass = 0;
6835                     }
6836                     break;
6837                 default: goto oops;
6838                 }
6839                 if (contextclass)
6840                      goto again;
6841                 break;
6842             case ' ':
6843                 proto++;
6844                 continue;
6845             default:
6846               oops:
6847                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6848                            gv_ename(namegv), SvPV((SV*)cv, n_a));
6849             }
6850         }
6851         else
6852             list(o2);
6853         mod(o2, OP_ENTERSUB);
6854         prev = o2;
6855         o2 = o2->op_sibling;
6856     }
6857     if (proto && !optional &&
6858           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6859         return too_few_arguments(o, gv_ename(namegv));
6860     return o;
6861 }
6862
6863 OP *
6864 Perl_ck_svconst(pTHX_ OP *o)
6865 {
6866     SvREADONLY_on(cSVOPo->op_sv);
6867     return o;
6868 }
6869
6870 OP *
6871 Perl_ck_trunc(pTHX_ OP *o)
6872 {
6873     if (o->op_flags & OPf_KIDS) {
6874         SVOP *kid = (SVOP*)cUNOPo->op_first;
6875
6876         if (kid->op_type == OP_NULL)
6877             kid = (SVOP*)kid->op_sibling;
6878         if (kid && kid->op_type == OP_CONST &&
6879             (kid->op_private & OPpCONST_BARE))
6880         {
6881             o->op_flags |= OPf_SPECIAL;
6882             kid->op_private &= ~OPpCONST_STRICT;
6883         }
6884     }
6885     return ck_fun(o);
6886 }
6887
6888 OP *
6889 Perl_ck_substr(pTHX_ OP *o)
6890 {
6891     o = ck_fun(o);
6892     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6893         OP *kid = cLISTOPo->op_first;
6894
6895         if (kid->op_type == OP_NULL)
6896             kid = kid->op_sibling;
6897         if (kid)
6898             kid->op_flags |= OPf_MOD;
6899
6900     }
6901     return o;
6902 }
6903
6904 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6905
6906 void
6907 Perl_peep(pTHX_ register OP *o)
6908 {
6909     register OP* oldop = 0;
6910     STRLEN n_a;
6911
6912     if (!o || o->op_seq)
6913         return;
6914     ENTER;
6915     SAVEOP();
6916     SAVEVPTR(PL_curcop);
6917     for (; o; o = o->op_next) {
6918         if (o->op_seq)
6919             break;
6920         if (!PL_op_seqmax)
6921             PL_op_seqmax++;
6922         PL_op = o;
6923         switch (o->op_type) {
6924         case OP_SETSTATE:
6925         case OP_NEXTSTATE:
6926         case OP_DBSTATE:
6927             PL_curcop = ((COP*)o);              /* for warnings */
6928             o->op_seq = PL_op_seqmax++;
6929             break;
6930
6931         case OP_CONST:
6932             if (cSVOPo->op_private & OPpCONST_STRICT)
6933                 no_bareword_allowed(o);
6934 #ifdef USE_ITHREADS
6935             /* Relocate sv to the pad for thread safety.
6936              * Despite being a "constant", the SV is written to,
6937              * for reference counts, sv_upgrade() etc. */
6938             if (cSVOP->op_sv) {
6939                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6940                 if (SvPADTMP(cSVOPo->op_sv)) {
6941                     /* If op_sv is already a PADTMP then it is being used by
6942                      * some pad, so make a copy. */
6943                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6944                     SvREADONLY_on(PL_curpad[ix]);
6945                     SvREFCNT_dec(cSVOPo->op_sv);
6946                 }
6947                 else {
6948                     SvREFCNT_dec(PL_curpad[ix]);
6949                     SvPADTMP_on(cSVOPo->op_sv);
6950                     PL_curpad[ix] = cSVOPo->op_sv;
6951                     /* XXX I don't know how this isn't readonly already. */
6952                     SvREADONLY_on(PL_curpad[ix]);
6953                 }
6954                 cSVOPo->op_sv = Nullsv;
6955                 o->op_targ = ix;
6956             }
6957 #endif
6958             o->op_seq = PL_op_seqmax++;
6959             break;
6960
6961         case OP_CONCAT:
6962             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6963                 if (o->op_next->op_private & OPpTARGET_MY) {
6964                     if (o->op_flags & OPf_STACKED) /* chained concats */
6965                         goto ignore_optimization;
6966                     else {
6967                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6968                         o->op_targ = o->op_next->op_targ;
6969                         o->op_next->op_targ = 0;
6970                         o->op_private |= OPpTARGET_MY;
6971                     }
6972                 }
6973                 op_null(o->op_next);
6974             }
6975           ignore_optimization:
6976             o->op_seq = PL_op_seqmax++;
6977             break;
6978         case OP_STUB:
6979             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6980                 o->op_seq = PL_op_seqmax++;
6981                 break; /* Scalar stub must produce undef.  List stub is noop */
6982             }
6983             goto nothin;
6984         case OP_NULL:
6985             if (o->op_targ == OP_NEXTSTATE
6986                 || o->op_targ == OP_DBSTATE
6987                 || o->op_targ == OP_SETSTATE)
6988             {
6989                 PL_curcop = ((COP*)o);
6990             }
6991             /* XXX: We avoid setting op_seq here to prevent later calls
6992                to peep() from mistakenly concluding that optimisation
6993                has already occurred. This doesn't fix the real problem,
6994                though (See 20010220.007). AMS 20010719 */
6995             if (oldop && o->op_next) {
6996                 oldop->op_next = o->op_next;
6997                 continue;
6998             }
6999             break;
7000         case OP_SCALAR:
7001         case OP_LINESEQ:
7002         case OP_SCOPE:
7003           nothin:
7004             if (oldop && o->op_next) {
7005                 oldop->op_next = o->op_next;
7006                 continue;
7007             }
7008             o->op_seq = PL_op_seqmax++;
7009             break;
7010
7011         case OP_GV:
7012             if (o->op_next->op_type == OP_RV2SV) {
7013                 if (!(o->op_next->op_private & OPpDEREF)) {
7014                     op_null(o->op_next);
7015                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7016                                                                | OPpOUR_INTRO);
7017                     o->op_next = o->op_next->op_next;
7018                     o->op_type = OP_GVSV;
7019                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7020                 }
7021             }
7022             else if (o->op_next->op_type == OP_RV2AV) {
7023                 OP* pop = o->op_next->op_next;
7024                 IV i;
7025                 if (pop->op_type == OP_CONST &&
7026                     (PL_op = pop->op_next) &&
7027                     pop->op_next->op_type == OP_AELEM &&
7028                     !(pop->op_next->op_private &
7029                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7030                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7031                                 <= 255 &&
7032                     i >= 0)
7033                 {
7034                     GV *gv;
7035                     op_null(o->op_next);
7036                     op_null(pop->op_next);
7037                     op_null(pop);
7038                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7039                     o->op_next = pop->op_next->op_next;
7040                     o->op_type = OP_AELEMFAST;
7041                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7042                     o->op_private = (U8)i;
7043                     gv = cGVOPo_gv;
7044                     GvAVn(gv);
7045                 }
7046             }
7047             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7048                 GV *gv = cGVOPo_gv;
7049                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7050                     /* XXX could check prototype here instead of just carping */
7051                     SV *sv = sv_newmortal();
7052                     gv_efullname3(sv, gv, Nullch);
7053                     Perl_warner(aTHX_ WARN_PROTOTYPE,
7054                                 "%s() called too early to check prototype",
7055                                 SvPV_nolen(sv));
7056                 }
7057             }
7058             else if (o->op_next->op_type == OP_READLINE
7059                     && o->op_next->op_next->op_type == OP_CONCAT
7060                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7061             {
7062                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7063                 o->op_type   = OP_RCATLINE;
7064                 o->op_flags |= OPf_STACKED;
7065                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7066                 op_null(o->op_next->op_next);
7067                 op_null(o->op_next);
7068             }
7069
7070             o->op_seq = PL_op_seqmax++;
7071             break;
7072
7073         case OP_MAPWHILE:
7074         case OP_GREPWHILE:
7075         case OP_AND:
7076         case OP_OR:
7077         case OP_ANDASSIGN:
7078         case OP_ORASSIGN:
7079         case OP_COND_EXPR:
7080         case OP_RANGE:
7081             o->op_seq = PL_op_seqmax++;
7082             while (cLOGOP->op_other->op_type == OP_NULL)
7083                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7084             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7085             break;
7086
7087         case OP_ENTERLOOP:
7088         case OP_ENTERITER:
7089             o->op_seq = PL_op_seqmax++;
7090             while (cLOOP->op_redoop->op_type == OP_NULL)
7091                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7092             peep(cLOOP->op_redoop);
7093             while (cLOOP->op_nextop->op_type == OP_NULL)
7094                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7095             peep(cLOOP->op_nextop);
7096             while (cLOOP->op_lastop->op_type == OP_NULL)
7097                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7098             peep(cLOOP->op_lastop);
7099             break;
7100
7101         case OP_QR:
7102         case OP_MATCH:
7103         case OP_SUBST:
7104             o->op_seq = PL_op_seqmax++;
7105             while (cPMOP->op_pmreplstart &&
7106                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7107                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7108             peep(cPMOP->op_pmreplstart);
7109             break;
7110
7111         case OP_EXEC:
7112             o->op_seq = PL_op_seqmax++;
7113             if (ckWARN(WARN_SYNTAX) && o->op_next
7114                 && o->op_next->op_type == OP_NEXTSTATE) {
7115                 if (o->op_next->op_sibling &&
7116                         o->op_next->op_sibling->op_type != OP_EXIT &&
7117                         o->op_next->op_sibling->op_type != OP_WARN &&
7118                         o->op_next->op_sibling->op_type != OP_DIE) {
7119                     line_t oldline = CopLINE(PL_curcop);
7120
7121                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7122                     Perl_warner(aTHX_ WARN_EXEC,
7123                                 "Statement unlikely to be reached");
7124                     Perl_warner(aTHX_ WARN_EXEC,
7125                                 "\t(Maybe you meant system() when you said exec()?)\n");
7126                     CopLINE_set(PL_curcop, oldline);
7127                 }
7128             }
7129             break;
7130
7131         case OP_HELEM: {
7132             UNOP *rop;
7133             SV *lexname;
7134             GV **fields;
7135             SV **svp, **indsvp, *sv;
7136             I32 ind;
7137             char *key = NULL;
7138             STRLEN keylen;
7139
7140             o->op_seq = PL_op_seqmax++;
7141
7142             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7143                 break;
7144
7145             /* Make the CONST have a shared SV */
7146             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7147             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7148                 key = SvPV(sv, keylen);
7149                 lexname = newSVpvn_share(key,
7150                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7151                                          0);
7152                 SvREFCNT_dec(sv);
7153                 *svp = lexname;
7154             }
7155
7156             if ((o->op_private & (OPpLVAL_INTRO)))
7157                 break;
7158
7159             rop = (UNOP*)((BINOP*)o)->op_first;
7160             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7161                 break;
7162             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7163             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7164                 break;
7165             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7166             if (!fields || !GvHV(*fields))
7167                 break;
7168             key = SvPV(*svp, keylen);
7169             indsvp = hv_fetch(GvHV(*fields), key,
7170                               SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7171             if (!indsvp) {
7172                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7173                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7174             }
7175             ind = SvIV(*indsvp);
7176             if (ind < 1)
7177                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7178             rop->op_type = OP_RV2AV;
7179             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7180             o->op_type = OP_AELEM;
7181             o->op_ppaddr = PL_ppaddr[OP_AELEM];
7182             sv = newSViv(ind);
7183             if (SvREADONLY(*svp))
7184                 SvREADONLY_on(sv);
7185             SvFLAGS(sv) |= (SvFLAGS(*svp)
7186                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7187             SvREFCNT_dec(*svp);
7188             *svp = sv;
7189             break;
7190         }
7191
7192         case OP_HSLICE: {
7193             UNOP *rop;
7194             SV *lexname;
7195             GV **fields;
7196             SV **svp, **indsvp, *sv;
7197             I32 ind;
7198             char *key;
7199             STRLEN keylen;
7200             SVOP *first_key_op, *key_op;
7201
7202             o->op_seq = PL_op_seqmax++;
7203             if ((o->op_private & (OPpLVAL_INTRO))
7204                 /* I bet there's always a pushmark... */
7205                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7206                 /* hmmm, no optimization if list contains only one key. */
7207                 break;
7208             rop = (UNOP*)((LISTOP*)o)->op_last;
7209             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7210                 break;
7211             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7212             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7213                 break;
7214             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7215             if (!fields || !GvHV(*fields))
7216                 break;
7217             /* Again guessing that the pushmark can be jumped over.... */
7218             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7219                 ->op_first->op_sibling;
7220             /* Check that the key list contains only constants. */
7221             for (key_op = first_key_op; key_op;
7222                  key_op = (SVOP*)key_op->op_sibling)
7223                 if (key_op->op_type != OP_CONST)
7224                     break;
7225             if (key_op)
7226                 break;
7227             rop->op_type = OP_RV2AV;
7228             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7229             o->op_type = OP_ASLICE;
7230             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7231             for (key_op = first_key_op; key_op;
7232                  key_op = (SVOP*)key_op->op_sibling) {
7233                 svp = cSVOPx_svp(key_op);
7234                 key = SvPV(*svp, keylen);
7235                 indsvp = hv_fetch(GvHV(*fields), key,
7236                                   SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7237                 if (!indsvp) {
7238                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7239                                "in variable %s of type %s",
7240                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7241                 }
7242                 ind = SvIV(*indsvp);
7243                 if (ind < 1)
7244                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7245                 sv = newSViv(ind);
7246                 if (SvREADONLY(*svp))
7247                     SvREADONLY_on(sv);
7248                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7249                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7250                 SvREFCNT_dec(*svp);
7251                 *svp = sv;
7252             }
7253             break;
7254         }
7255
7256         default:
7257             o->op_seq = PL_op_seqmax++;
7258             break;
7259         }
7260         oldop = o;
7261     }
7262     LEAVE;
7263 }
7264
7265
7266
7267 char* Perl_custom_op_name(pTHX_ OP* o)
7268 {
7269     IV  index = PTR2IV(o->op_ppaddr);
7270     SV* keysv;
7271     HE* he;
7272
7273     if (!PL_custom_op_names) /* This probably shouldn't happen */
7274         return PL_op_name[OP_CUSTOM];
7275
7276     keysv = sv_2mortal(newSViv(index));
7277
7278     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7279     if (!he)
7280         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7281
7282     return SvPV_nolen(HeVAL(he));
7283 }
7284
7285 char* Perl_custom_op_desc(pTHX_ OP* o)
7286 {
7287     IV  index = PTR2IV(o->op_ppaddr);
7288     SV* keysv;
7289     HE* he;
7290
7291     if (!PL_custom_op_descs)
7292         return PL_op_desc[OP_CUSTOM];
7293
7294     keysv = sv_2mortal(newSViv(index));
7295
7296     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7297     if (!he)
7298         return PL_op_desc[OP_CUSTOM];
7299
7300     return SvPV_nolen(HeVAL(he));
7301 }
7302
7303
7304 #include "XSUB.h"
7305
7306 /* Efficient sub that returns a constant scalar value. */
7307 static void
7308 const_sv_xsub(pTHX_ CV* cv)
7309 {
7310     dXSARGS;
7311     if (items != 0) {
7312 #if 0
7313         Perl_croak(aTHX_ "usage: %s::%s()",
7314                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7315 #endif
7316     }
7317     EXTEND(sp, 1);
7318     ST(0) = (SV*)XSANY.any_ptr;
7319     XSRETURN(1);
7320 }
7321