op.c

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