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