op.c

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