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