op.c

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