op.c

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