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