pp_ctl.c

   1 /*    pp_ctl.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  * Now far ahead the Road has gone,
  12  * And I must follow, if I can,
  13  * Pursuing it with eager feet,
  14  * Until it joins some larger way
  15  * Where many paths and errands meet.
  16  * And whither then?  I cannot say.
  17  */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_PP_CTL_C
  21 #include "perl.h"
  22
  23 #ifndef WORD_ALIGN
  24 #define WORD_ALIGN sizeof(U16)
  25 #endif
  26
  27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  28
  29 static I32 sortcv(pTHXo_ SV *a, SV *b);
  30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
  31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
  32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
  33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
  34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
  35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
  36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
  37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
  38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
  39
  40 #ifdef PERL_OBJECT
  41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
  42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
  43 #else
  44 #define sv_cmp_static Perl_sv_cmp
  45 #define sv_cmp_locale_static Perl_sv_cmp_locale
  46 #endif
  47
  48 PP(pp_wantarray)
  49 {
  50     djSP;
  51     I32 cxix;
  52     EXTEND(SP, 1);
  53
  54     cxix = dopoptosub(cxstack_ix);
  55     if (cxix < 0)
  56         RETPUSHUNDEF;
  57
  58     switch (cxstack[cxix].blk_gimme) {
  59     case G_ARRAY:
  60         RETPUSHYES;
  61     case G_SCALAR:
  62         RETPUSHNO;
  63     default:
  64         RETPUSHUNDEF;
  65     }
  66 }
  67
  68 PP(pp_regcmaybe)
  69 {
  70     return NORMAL;
  71 }
  72
  73 PP(pp_regcreset)
  74 {
  75     /* XXXX Should store the old value to allow for tie/overload - and
  76        restore in regcomp, where marked with XXXX. */
  77     PL_reginterp_cnt = 0;
  78     return NORMAL;
  79 }
  80
  81 PP(pp_regcomp)
  82 {
  83     djSP;
  84     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  85     register char *t;
  86     SV *tmpstr;
  87     STRLEN len;
  88     MAGIC *mg = Null(MAGIC*);
  89
  90     tmpstr = POPs;
  91     if (SvROK(tmpstr)) {
  92         SV *sv = SvRV(tmpstr);
  93         if(SvMAGICAL(sv))
  94             mg = mg_find(sv, 'r');
  95     }
  96     if (mg) {
  97         regexp *re = (regexp *)mg->mg_obj;
  98         ReREFCNT_dec(pm->op_pmregexp);
  99         pm->op_pmregexp = ReREFCNT_inc(re);
 100     }
 101     else {
 102         t = SvPV(tmpstr, len);
 103
 104         /* Check against the last compiled regexp. */
 105         if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
 106             pm->op_pmregexp->prelen != len ||
 107             memNE(pm->op_pmregexp->precomp, t, len))
 108         {
 109             if (pm->op_pmregexp) {
 110                 ReREFCNT_dec(pm->op_pmregexp);
 111                 pm->op_pmregexp = Null(REGEXP*);        /* crucial if regcomp aborts */
 112             }
 113             if (PL_op->op_flags & OPf_SPECIAL)
 114                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 115
 116             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
 117             pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
 118             PL_reginterp_cnt = 0;               /* XXXX Be extra paranoid - needed
 119                                            inside tie/overload accessors.  */
 120         }
 121     }
 122
 123 #ifndef INCOMPLETE_TAINTS
 124     if (PL_tainting) {
 125         if (PL_tainted)
 126             pm->op_pmdynflags |= PMdf_TAINTED;
 127         else
 128             pm->op_pmdynflags &= ~PMdf_TAINTED;
 129     }
 130 #endif
 131
 132     if (!pm->op_pmregexp->prelen && PL_curpm)
 133         pm = PL_curpm;
 134     else if (strEQ("\\s+", pm->op_pmregexp->precomp))
 135         pm->op_pmflags |= PMf_WHITE;
 136
 137     /* XXX runtime compiled output needs to move to the pad */
 138     if (pm->op_pmflags & PMf_KEEP) {
 139         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 140 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
 141         /* XXX can't change the optree at runtime either */
 142         cLOGOP->op_first->op_next = PL_op->op_next;
 143 #endif
 144     }
 145     RETURN;
 146 }
 147
 148 PP(pp_substcont)
 149 {
 150     djSP;
 151     register PMOP *pm = (PMOP*) cLOGOP->op_other;
 152     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 153     register SV *dstr = cx->sb_dstr;
 154     register char *s = cx->sb_s;
 155     register char *m = cx->sb_m;
 156     char *orig = cx->sb_orig;
 157     register REGEXP *rx = cx->sb_rx;
 158
 159     rxres_restore(&cx->sb_rxres, rx);
 160
 161     if (cx->sb_iters++) {
 162         if (cx->sb_iters > cx->sb_maxiters)
 163             DIE(aTHX_ "Substitution loop");
 164
 165         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 166             cx->sb_rxtainted |= 2;
 167         sv_catsv(dstr, POPs);
 168
 169         /* Are we done */
 170         if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
 171                                      s == m, cx->sb_targ, NULL,
 172                                      ((cx->sb_rflags & REXEC_COPY_STR)
 173                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 174                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 175         {
 176             SV *targ = cx->sb_targ;
 177             sv_catpvn(dstr, s, cx->sb_strend - s);
 178
 179             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 180
 181             (void)SvOOK_off(targ);
 182             Safefree(SvPVX(targ));
 183             SvPVX(targ) = SvPVX(dstr);
 184             SvCUR_set(targ, SvCUR(dstr));
 185             SvLEN_set(targ, SvLEN(dstr));
 186             SvPVX(dstr) = 0;
 187             sv_free(dstr);
 188
 189             TAINT_IF(cx->sb_rxtainted & 1);
 190             PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
 191
 192             (void)SvPOK_only(targ);
 193             TAINT_IF(cx->sb_rxtainted);
 194             SvSETMAGIC(targ);
 195             SvTAINT(targ);
 196
 197             LEAVE_SCOPE(cx->sb_oldsave);
 198             POPSUBST(cx);
 199             RETURNOP(pm->op_next);
 200         }
 201     }
 202     if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 203         m = s;
 204         s = orig;
 205         cx->sb_orig = orig = rx->subbeg;
 206         s = orig + (m - s);
 207         cx->sb_strend = s + (cx->sb_strend - m);
 208     }
 209     cx->sb_m = m = rx->startp[0] + orig;
 210     sv_catpvn(dstr, s, m-s);
 211     cx->sb_s = rx->endp[0] + orig;
 212     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 213     rxres_save(&cx->sb_rxres, rx);
 214     RETURNOP(pm->op_pmreplstart);
 215 }
 216
 217 void
 218 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 219 {
 220     UV *p = (UV*)*rsp;
 221     U32 i;
 222
 223     if (!p || p[1] < rx->nparens) {
 224         i = 6 + rx->nparens * 2;
 225         if (!p)
 226             New(501, p, i, UV);
 227         else
 228             Renew(p, i, UV);
 229         *rsp = (void*)p;
 230     }
 231
 232     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
 233     RX_MATCH_COPIED_off(rx);
 234
 235     *p++ = rx->nparens;
 236
 237     *p++ = PTR2UV(rx->subbeg);
 238     *p++ = (UV)rx->sublen;
 239     for (i = 0; i <= rx->nparens; ++i) {
 240         *p++ = (UV)rx->startp[i];
 241         *p++ = (UV)rx->endp[i];
 242     }
 243 }
 244
 245 void
 246 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 247 {
 248     UV *p = (UV*)*rsp;
 249     U32 i;
 250
 251     if (RX_MATCH_COPIED(rx))
 252         Safefree(rx->subbeg);
 253     RX_MATCH_COPIED_set(rx, *p);
 254     *p++ = 0;
 255
 256     rx->nparens = *p++;
 257
 258     rx->subbeg = INT2PTR(char*,*p++);
 259     rx->sublen = (I32)(*p++);
 260     for (i = 0; i <= rx->nparens; ++i) {
 261         rx->startp[i] = (I32)(*p++);
 262         rx->endp[i] = (I32)(*p++);
 263     }
 264 }
 265
 266 void
 267 Perl_rxres_free(pTHX_ void **rsp)
 268 {
 269     UV *p = (UV*)*rsp;
 270
 271     if (p) {
 272         Safefree(INT2PTR(char*,*p));
 273         Safefree(p);
 274         *rsp = Null(void*);
 275     }
 276 }
 277
 278 PP(pp_formline)
 279 {
 280     djSP; dMARK; dORIGMARK;
 281     register SV *tmpForm = *++MARK;
 282     register U16 *fpc;
 283     register char *t;
 284     register char *f;
 285     register char *s;
 286     register char *send;
 287     register I32 arg;
 288     register SV *sv;
 289     char *item;
 290     I32 itemsize;
 291     I32 fieldsize;
 292     I32 lines = 0;
 293     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
 294     char *chophere;
 295     char *linemark;
 296     NV value;
 297     bool gotsome;
 298     STRLEN len;
 299     STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
 300
 301     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 302         SvREADONLY_off(tmpForm);
 303         doparseform(tmpForm);
 304     }
 305
 306     SvPV_force(PL_formtarget, len);
 307     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 308     t += len;
 309     f = SvPV(tmpForm, len);
 310     /* need to jump to the next word */
 311     s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
 312
 313     fpc = (U16*)s;
 314
 315     for (;;) {
 316         DEBUG_f( {
 317             char *name = "???";
 318             arg = -1;
 319             switch (*fpc) {
 320             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 321             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 322             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 323             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 324             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 325
 326             case FF_CHECKNL:    name = "CHECKNL";       break;
 327             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 328             case FF_SPACE:      name = "SPACE";         break;
 329             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 330             case FF_ITEM:       name = "ITEM";          break;
 331             case FF_CHOP:       name = "CHOP";          break;
 332             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 333             case FF_NEWLINE:    name = "NEWLINE";       break;
 334             case FF_MORE:       name = "MORE";          break;
 335             case FF_LINEMARK:   name = "LINEMARK";      break;
 336             case FF_END:        name = "END";           break;
 337             }
 338             if (arg >= 0)
 339                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 340             else
 341                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 342         } )
 343         switch (*fpc++) {
 344         case FF_LINEMARK:
 345             linemark = t;
 346             lines++;
 347             gotsome = FALSE;
 348             break;
 349
 350         case FF_LITERAL:
 351             arg = *fpc++;
 352             while (arg--)
 353                 *t++ = *f++;
 354             break;
 355
 356         case FF_SKIP:
 357             f += *fpc++;
 358             break;
 359
 360         case FF_FETCH:
 361             arg = *fpc++;
 362             f += arg;
 363             fieldsize = arg;
 364
 365             if (MARK < SP)
 366                 sv = *++MARK;
 367             else {
 368                 sv = &PL_sv_no;
 369                 if (ckWARN(WARN_SYNTAX))
 370                     Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
 371             }
 372             break;
 373
 374         case FF_CHECKNL:
 375             item = s = SvPV(sv, len);
 376             itemsize = len;
 377             if (IN_UTF8) {
 378                 itemsize = sv_len_utf8(sv);
 379                 if (itemsize != len) {
 380                     I32 itembytes;
 381                     if (itemsize > fieldsize) {
 382                         itemsize = fieldsize;
 383                         itembytes = itemsize;
 384                         sv_pos_u2b(sv, &itembytes, 0);
 385                     }
 386                     else
 387                         itembytes = len;
 388                     send = chophere = s + itembytes;
 389                     while (s < send) {
 390                         if (*s & ~31)
 391                             gotsome = TRUE;
 392                         else if (*s == '\n')
 393                             break;
 394                         s++;
 395                     }
 396                     itemsize = s - item;
 397                     sv_pos_b2u(sv, &itemsize);
 398                     break;
 399                 }
 400             }
 401             if (itemsize > fieldsize)
 402                 itemsize = fieldsize;
 403             send = chophere = s + itemsize;
 404             while (s < send) {
 405                 if (*s & ~31)
 406                     gotsome = TRUE;
 407                 else if (*s == '\n')
 408                     break;
 409                 s++;
 410             }
 411             itemsize = s - item;
 412             break;
 413
 414         case FF_CHECKCHOP:
 415             item = s = SvPV(sv, len);
 416             itemsize = len;
 417             if (IN_UTF8) {
 418                 itemsize = sv_len_utf8(sv);
 419                 if (itemsize != len) {
 420                     I32 itembytes;
 421                     if (itemsize <= fieldsize) {
 422                         send = chophere = s + itemsize;
 423                         while (s < send) {
 424                             if (*s == '\r') {
 425                                 itemsize = s - item;
 426                                 break;
 427                             }
 428                             if (*s++ & ~31)
 429                                 gotsome = TRUE;
 430                         }
 431                     }
 432                     else {
 433                         itemsize = fieldsize;
 434                         itembytes = itemsize;
 435                         sv_pos_u2b(sv, &itembytes, 0);
 436                         send = chophere = s + itembytes;
 437                         while (s < send || (s == send && isSPACE(*s))) {
 438                             if (isSPACE(*s)) {
 439                                 if (chopspace)
 440                                     chophere = s;
 441                                 if (*s == '\r')
 442                                     break;
 443                             }
 444                             else {
 445                                 if (*s & ~31)
 446                                     gotsome = TRUE;
 447                                 if (strchr(PL_chopset, *s))
 448                                     chophere = s + 1;
 449                             }
 450                             s++;
 451                         }
 452                         itemsize = chophere - item;
 453                         sv_pos_b2u(sv, &itemsize);
 454                     }
 455                     break;
 456                 }
 457             }
 458             if (itemsize <= fieldsize) {
 459                 send = chophere = s + itemsize;
 460                 while (s < send) {
 461                     if (*s == '\r') {
 462                         itemsize = s - item;
 463                         break;
 464                     }
 465                     if (*s++ & ~31)
 466                         gotsome = TRUE;
 467                 }
 468             }
 469             else {
 470                 itemsize = fieldsize;
 471                 send = chophere = s + itemsize;
 472                 while (s < send || (s == send && isSPACE(*s))) {
 473                     if (isSPACE(*s)) {
 474                         if (chopspace)
 475                             chophere = s;
 476                         if (*s == '\r')
 477                             break;
 478                     }
 479                     else {
 480                         if (*s & ~31)
 481                             gotsome = TRUE;
 482                         if (strchr(PL_chopset, *s))
 483                             chophere = s + 1;
 484                     }
 485                     s++;
 486                 }
 487                 itemsize = chophere - item;
 488             }
 489             break;
 490
 491         case FF_SPACE:
 492             arg = fieldsize - itemsize;
 493             if (arg) {
 494                 fieldsize -= arg;
 495                 while (arg-- > 0)
 496                     *t++ = ' ';
 497             }
 498             break;
 499
 500         case FF_HALFSPACE:
 501             arg = fieldsize - itemsize;
 502             if (arg) {
 503                 arg /= 2;
 504                 fieldsize -= arg;
 505                 while (arg-- > 0)
 506                     *t++ = ' ';
 507             }
 508             break;
 509
 510         case FF_ITEM:
 511             arg = itemsize;
 512             s = item;
 513             if (IN_UTF8) {
 514                 while (arg--) {
 515                     if (*s & 0x80) {
 516                         switch (UTF8SKIP(s)) {
 517                         case 7: *t++ = *s++;
 518                         case 6: *t++ = *s++;
 519                         case 5: *t++ = *s++;
 520                         case 4: *t++ = *s++;
 521                         case 3: *t++ = *s++;
 522                         case 2: *t++ = *s++;
 523                         case 1: *t++ = *s++;
 524                         }
 525                     }
 526                     else {
 527                         if ( !((*t++ = *s++) & ~31) )
 528                             t[-1] = ' ';
 529                     }
 530                 }
 531                 break;
 532             }
 533             while (arg--) {
 534 #ifdef EBCDIC
 535                 int ch = *t++ = *s++;
 536                 if (iscntrl(ch))
 537 #else
 538                 if ( !((*t++ = *s++) & ~31) )
 539 #endif
 540                     t[-1] = ' ';
 541             }
 542             break;
 543
 544         case FF_CHOP:
 545             s = chophere;
 546             if (chopspace) {
 547                 while (*s && isSPACE(*s))
 548                     s++;
 549             }
 550             sv_chop(sv,s);
 551             break;
 552
 553         case FF_LINEGLOB:
 554             item = s = SvPV(sv, len);
 555             itemsize = len;
 556             if (itemsize) {
 557                 gotsome = TRUE;
 558                 send = s + itemsize;
 559                 while (s < send) {
 560                     if (*s++ == '\n') {
 561                         if (s == send)
 562                             itemsize--;
 563                         else
 564                             lines++;
 565                     }
 566                 }
 567                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 568                 sv_catpvn(PL_formtarget, item, itemsize);
 569                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 570                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 571             }
 572             break;
 573
 574         case FF_DECIMAL:
 575             /* If the field is marked with ^ and the value is undefined,
 576                blank it out. */
 577             arg = *fpc++;
 578             if ((arg & 512) && !SvOK(sv)) {
 579                 arg = fieldsize;
 580                 while (arg--)
 581                     *t++ = ' ';
 582                 break;
 583             }
 584             gotsome = TRUE;
 585             value = SvNV(sv);
 586             /* Formats aren't yet marked for locales, so assume "yes". */
 587             {
 588                 RESTORE_NUMERIC_LOCAL();
 589 #if defined(USE_LONG_DOUBLE)
 590                 if (arg & 256) {
 591                     sprintf(t, "%#*.*" PERL_PRIfldbl,
 592                             (int) fieldsize, (int) arg & 255, value);
 593                 } else {
 594                     sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
 595                 }
 596 #else
 597                 if (arg & 256) {
 598                     sprintf(t, "%#*.*f",
 599                             (int) fieldsize, (int) arg & 255, value);
 600                 } else {
 601                     sprintf(t, "%*.0f",
 602                             (int) fieldsize, value);
 603                 }
 604 #endif
 605                 RESTORE_NUMERIC_STANDARD();
 606             }
 607             t += fieldsize;
 608             break;
 609
 610         case FF_NEWLINE:
 611             f++;
 612             while (t-- > linemark && *t == ' ') ;
 613             t++;
 614             *t++ = '\n';
 615             break;
 616
 617         case FF_BLANK:
 618             arg = *fpc++;
 619             if (gotsome) {
 620                 if (arg) {              /* repeat until fields exhausted? */
 621                     *t = '\0';
 622                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 623                     lines += FmLINES(PL_formtarget);
 624                     if (lines == 200) {
 625                         arg = t - linemark;
 626                         if (strnEQ(linemark, linemark - arg, arg))
 627                             DIE(aTHX_ "Runaway format");
 628                     }
 629                     FmLINES(PL_formtarget) = lines;
 630                     SP = ORIGMARK;
 631                     RETURNOP(cLISTOP->op_first);
 632                 }
 633             }
 634             else {
 635                 t = linemark;
 636                 lines--;
 637             }
 638             break;
 639
 640         case FF_MORE:
 641             s = chophere;
 642             send = item + len;
 643             if (chopspace) {
 644                 while (*s && isSPACE(*s) && s < send)
 645                     s++;
 646             }
 647             if (s < send) {
 648                 arg = fieldsize - itemsize;
 649                 if (arg) {
 650                     fieldsize -= arg;
 651                     while (arg-- > 0)
 652                         *t++ = ' ';
 653                 }
 654                 s = t - 3;
 655                 if (strnEQ(s,"   ",3)) {
 656                     while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
 657                         s--;
 658                 }
 659                 *s++ = '.';
 660                 *s++ = '.';
 661                 *s++ = '.';
 662             }
 663             break;
 664
 665         case FF_END:
 666             *t = '\0';
 667             SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 668             FmLINES(PL_formtarget) += lines;
 669             SP = ORIGMARK;
 670             RETPUSHYES;
 671         }
 672     }
 673 }
 674
 675 PP(pp_grepstart)
 676 {
 677     djSP;
 678     SV *src;
 679
 680     if (PL_stack_base + *PL_markstack_ptr == SP) {
 681         (void)POPMARK;
 682         if (GIMME_V == G_SCALAR)
 683             XPUSHs(sv_2mortal(newSViv(0)));
 684         RETURNOP(PL_op->op_next->op_next);
 685     }
 686     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 687     pp_pushmark();                              /* push dst */
 688     pp_pushmark();                              /* push src */
 689     ENTER;                                      /* enter outer scope */
 690
 691     SAVETMPS;
 692     /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
 693     SAVESPTR(DEFSV);
 694     ENTER;                                      /* enter inner scope */
 695     SAVEVPTR(PL_curpm);
 696
 697     src = PL_stack_base[*PL_markstack_ptr];
 698     SvTEMP_off(src);
 699     DEFSV = src;
 700
 701     PUTBACK;
 702     if (PL_op->op_type == OP_MAPSTART)
 703         pp_pushmark();                  /* push top */
 704     return ((LOGOP*)PL_op->op_next)->op_other;
 705 }
 706
 707 PP(pp_mapstart)
 708 {
 709     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 710 }
 711
 712 PP(pp_mapwhile)
 713 {
 714     djSP;
 715     I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
 716     I32 count;
 717     I32 shift;
 718     SV** src;
 719     SV** dst;
 720
 721     ++PL_markstack_ptr[-1];
 722     if (diff) {
 723         if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 724             shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 725             count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
 726
 727             EXTEND(SP,shift);
 728             src = SP;
 729             dst = (SP += shift);
 730             PL_markstack_ptr[-1] += shift;
 731             *PL_markstack_ptr += shift;
 732             while (--count)
 733                 *dst-- = *src--;
 734         }
 735         dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
 736         ++diff;
 737         while (--diff)
 738             *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
 739     }
 740     LEAVE;                                      /* exit inner scope */
 741
 742     /* All done yet? */
 743     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
 744         I32 items;
 745         I32 gimme = GIMME_V;
 746
 747         (void)POPMARK;                          /* pop top */
 748         LEAVE;                                  /* exit outer scope */
 749         (void)POPMARK;                          /* pop src */
 750         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
 751         (void)POPMARK;                          /* pop dst */
 752         SP = PL_stack_base + POPMARK;           /* pop original mark */
 753         if (gimme == G_SCALAR) {
 754             dTARGET;
 755             XPUSHi(items);
 756         }
 757         else if (gimme == G_ARRAY)
 758             SP += items;
 759         RETURN;
 760     }
 761     else {
 762         SV *src;
 763
 764         ENTER;                                  /* enter inner scope */
 765         SAVEVPTR(PL_curpm);
 766
 767         src = PL_stack_base[PL_markstack_ptr[-1]];
 768         SvTEMP_off(src);
 769         DEFSV = src;
 770
 771         RETURNOP(cLOGOP->op_other);
 772     }
 773 }
 774
 775 PP(pp_sort)
 776 {
 777     djSP; dMARK; dORIGMARK;
 778     register SV **up;
 779     SV **myorigmark = ORIGMARK;
 780     register I32 max;
 781     HV *stash;
 782     GV *gv;
 783     CV *cv;
 784     I32 gimme = GIMME;
 785     OP* nextop = PL_op->op_next;
 786     I32 overloading = 0;
 787     bool hasargs = FALSE;
 788     I32 is_xsub = 0;
 789
 790     if (gimme != G_ARRAY) {
 791         SP = MARK;
 792         RETPUSHUNDEF;
 793     }
 794
 795     ENTER;
 796     SAVEVPTR(PL_sortcop);
 797     if (PL_op->op_flags & OPf_STACKED) {
 798         if (PL_op->op_flags & OPf_SPECIAL) {
 799             OP *kid = cLISTOP->op_first->op_sibling;    /* pass pushmark */
 800             kid = kUNOP->op_first;                      /* pass rv2gv */
 801             kid = kUNOP->op_first;                      /* pass leave */
 802             PL_sortcop = kid->op_next;
 803             stash = CopSTASH(PL_curcop);
 804         }
 805         else {
 806             cv = sv_2cv(*++MARK, &stash, &gv, 0);
 807             if (cv && SvPOK(cv)) {
 808                 STRLEN n_a;
 809                 char *proto = SvPV((SV*)cv, n_a);
 810                 if (proto && strEQ(proto, "$$")) {
 811                     hasargs = TRUE;
 812                 }
 813             }
 814             if (!(cv && CvROOT(cv))) {
 815                 if (cv && CvXSUB(cv)) {
 816                     is_xsub = 1;
 817                 }
 818                 else if (gv) {
 819                     SV *tmpstr = sv_newmortal();
 820                     gv_efullname3(tmpstr, gv, Nullch);
 821                     DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
 822                         SvPVX(tmpstr));
 823                 }
 824                 else {
 825                     DIE(aTHX_ "Undefined subroutine in sort");
 826                 }
 827             }
 828
 829             if (is_xsub)
 830                 PL_sortcop = (OP*)cv;
 831             else {
 832                 PL_sortcop = CvSTART(cv);
 833                 SAVEVPTR(CvROOT(cv)->op_ppaddr);
 834                 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 835
 836                 SAVEVPTR(PL_curpad);
 837                 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 838             }
 839         }
 840     }
 841     else {
 842         PL_sortcop = Nullop;
 843         stash = CopSTASH(PL_curcop);
 844     }
 845
 846     up = myorigmark + 1;
 847     while (MARK < SP) { /* This may or may not shift down one here. */
 848         /*SUPPRESS 560*/
 849         if (*up = *++MARK) {                    /* Weed out nulls. */
 850             SvTEMP_off(*up);
 851             if (!PL_sortcop && !SvPOK(*up)) {
 852                 STRLEN n_a;
 853                 if (SvAMAGIC(*up))
 854                     overloading = 1;
 855                 else
 856                     (void)sv_2pv(*up, &n_a);
 857             }
 858             up++;
 859         }
 860     }
 861     max = --up - myorigmark;
 862     if (PL_sortcop) {
 863         if (max > 1) {
 864             PERL_CONTEXT *cx;
 865             SV** newsp;
 866             bool oldcatch = CATCH_GET;
 867
 868             SAVETMPS;
 869             SAVEOP();
 870
 871             CATCH_SET(TRUE);
 872             PUSHSTACKi(PERLSI_SORT);
 873             if (PL_sortstash != stash) {
 874                 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
 875                 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
 876                 PL_sortstash = stash;
 877             }
 878
 879             SAVESPTR(GvSV(PL_firstgv));
 880             SAVESPTR(GvSV(PL_secondgv));
 881
 882             PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
 883             if (!(PL_op->op_flags & OPf_SPECIAL)) {
 884                 cx->cx_type = CXt_SUB;
 885                 cx->blk_gimme = G_SCALAR;
 886                 PUSHSUB(cx);
 887                 if (!CvDEPTH(cv))
 888                     (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
 889             }
 890             PL_sortcxix = cxstack_ix;
 891
 892             if (hasargs && !is_xsub) {
 893                 /* This is mostly copied from pp_entersub */
 894                 AV *av = (AV*)PL_curpad[0];
 895
 896 #ifndef USE_THREADS
 897                 cx->blk_sub.savearray = GvAV(PL_defgv);
 898                 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
 899 #endif /* USE_THREADS */
 900                 cx->blk_sub.argarray = av;
 901             }
 902             qsortsv((myorigmark+1), max,
 903                     is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
 904
 905             POPBLOCK(cx,PL_curpm);
 906             PL_stack_sp = newsp;
 907             POPSTACK;
 908             CATCH_SET(oldcatch);
 909         }
 910     }
 911     else {
 912         if (max > 1) {
 913             MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
 914             qsortsv(ORIGMARK+1, max,
 915                     (PL_op->op_private & OPpSORT_NUMERIC)
 916                         ? ( (PL_op->op_private & OPpSORT_INTEGER)
 917                             ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
 918                             : ( overloading ? amagic_ncmp : sv_ncmp))
 919                         : ( (PL_op->op_private & OPpLOCALE)
 920                             ? ( overloading
 921                                 ? amagic_cmp_locale
 922                                 : sv_cmp_locale_static)
 923                             : ( overloading ? amagic_cmp : sv_cmp_static)));
 924             if (PL_op->op_private & OPpSORT_REVERSE) {
 925                 SV **p = ORIGMARK+1;
 926                 SV **q = ORIGMARK+max;
 927                 while (p < q) {
 928                     SV *tmp = *p;
 929                     *p++ = *q;
 930                     *q-- = tmp;
 931                 }
 932             }
 933         }
 934     }
 935     LEAVE;
 936     PL_stack_sp = ORIGMARK + max;
 937     return nextop;
 938 }
 939
 940 /* Range stuff. */
 941
 942 PP(pp_range)
 943 {
 944     if (GIMME == G_ARRAY)
 945         return NORMAL;
 946     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
 947         return cLOGOP->op_other;
 948     else
 949         return NORMAL;
 950 }
 951
 952 PP(pp_flip)
 953 {
 954     djSP;
 955
 956     if (GIMME == G_ARRAY) {
 957         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 958     }
 959     else {
 960         dTOPss;
 961         SV *targ = PAD_SV(PL_op->op_targ);
 962
 963         if ((PL_op->op_private & OPpFLIP_LINENUM)
 964           ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
 965           : SvTRUE(sv) ) {
 966             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
 967             if (PL_op->op_flags & OPf_SPECIAL) {
 968                 sv_setiv(targ, 1);
 969                 SETs(targ);
 970                 RETURN;
 971             }
 972             else {
 973                 sv_setiv(targ, 0);
 974                 SP--;
 975                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 976             }
 977         }
 978         sv_setpv(TARG, "");
 979         SETs(targ);
 980         RETURN;
 981     }
 982 }
 983
 984 PP(pp_flop)
 985 {
 986     djSP;
 987
 988     if (GIMME == G_ARRAY) {
 989         dPOPPOPssrl;
 990         register I32 i, j;
 991         register SV *sv;
 992         I32 max;
 993
 994         if (SvGMAGICAL(left))
 995             mg_get(left);
 996         if (SvGMAGICAL(right))
 997             mg_get(right);
 998
 999         if (SvNIOKp(left) || !SvPOKp(left) ||
1000             SvNIOKp(right) || !SvPOKp(right) ||
1001             (looks_like_number(left) && *SvPVX(left) != '0' &&
1002              looks_like_number(right) && *SvPVX(right) != '0'))
1003         {
1004             if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1005                 DIE(aTHX_ "Range iterator outside integer range");
1006             i = SvIV(left);
1007             max = SvIV(right);
1008             if (max >= i) {
1009                 j = max - i + 1;
1010                 EXTEND_MORTAL(j);
1011                 EXTEND(SP, j);
1012             }
1013             else
1014                 j = 0;
1015             while (j--) {
1016                 sv = sv_2mortal(newSViv(i++));
1017                 PUSHs(sv);
1018             }
1019         }
1020         else {
1021             SV *final = sv_mortalcopy(right);
1022             STRLEN len, n_a;
1023             char *tmps = SvPV(final, len);
1024
1025             sv = sv_mortalcopy(left);
1026             SvPV_force(sv,n_a);
1027             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1028                 XPUSHs(sv);
1029                 if (strEQ(SvPVX(sv),tmps))
1030                     break;
1031                 sv = sv_2mortal(newSVsv(sv));
1032                 sv_inc(sv);
1033             }
1034         }
1035     }
1036     else {
1037         dTOPss;
1038         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1039         sv_inc(targ);
1040         if ((PL_op->op_private & OPpFLIP_LINENUM)
1041           ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1042           : SvTRUE(sv) ) {
1043             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1044             sv_catpv(targ, "E0");
1045         }
1046         SETs(targ);
1047     }
1048
1049     RETURN;
1050 }
1051
1052 /* Control. */
1053
1054 STATIC I32
1055 S_dopoptolabel(pTHX_ char *label)
1056 {
1057     dTHR;
1058     register I32 i;
1059     register PERL_CONTEXT *cx;
1060
1061     for (i = cxstack_ix; i >= 0; i--) {
1062         cx = &cxstack[i];
1063         switch (CxTYPE(cx)) {
1064         case CXt_SUBST:
1065             if (ckWARN(WARN_UNSAFE))
1066                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1067                         PL_op_name[PL_op->op_type]);
1068             break;
1069         case CXt_SUB:
1070             if (ckWARN(WARN_UNSAFE))
1071                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1072                         PL_op_name[PL_op->op_type]);
1073             break;
1074         case CXt_FORMAT:
1075             if (ckWARN(WARN_UNSAFE))
1076                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1077                         PL_op_name[PL_op->op_type]);
1078             break;
1079         case CXt_EVAL:
1080             if (ckWARN(WARN_UNSAFE))
1081                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1082                         PL_op_name[PL_op->op_type]);
1083             break;
1084         case CXt_NULL:
1085             if (ckWARN(WARN_UNSAFE))
1086                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1087                         PL_op_name[PL_op->op_type]);
1088             return -1;
1089         case CXt_LOOP:
1090             if (!cx->blk_loop.label ||
1091               strNE(label, cx->blk_loop.label) ) {
1092                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1093                         (long)i, cx->blk_loop.label));
1094                 continue;
1095             }
1096             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1097             return i;
1098         }
1099     }
1100     return i;
1101 }
1102
1103 I32
1104 Perl_dowantarray(pTHX)
1105 {
1106     I32 gimme = block_gimme();
1107     return (gimme == G_VOID) ? G_SCALAR : gimme;
1108 }
1109
1110 I32
1111 Perl_block_gimme(pTHX)
1112 {
1113     dTHR;
1114     I32 cxix;
1115
1116     cxix = dopoptosub(cxstack_ix);
1117     if (cxix < 0)
1118         return G_VOID;
1119
1120     switch (cxstack[cxix].blk_gimme) {
1121     case G_VOID:
1122         return G_VOID;
1123     case G_SCALAR:
1124         return G_SCALAR;
1125     case G_ARRAY:
1126         return G_ARRAY;
1127     default:
1128         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1129         /* NOTREACHED */
1130         return 0;
1131     }
1132 }
1133
1134 STATIC I32
1135 S_dopoptosub(pTHX_ I32 startingblock)
1136 {
1137     dTHR;
1138     return dopoptosub_at(cxstack, startingblock);
1139 }
1140
1141 STATIC I32
1142 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1143 {
1144     dTHR;
1145     I32 i;
1146     register PERL_CONTEXT *cx;
1147     for (i = startingblock; i >= 0; i--) {
1148         cx = &cxstk[i];
1149         switch (CxTYPE(cx)) {
1150         default:
1151             continue;
1152         case CXt_EVAL:
1153         case CXt_SUB:
1154         case CXt_FORMAT:
1155             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1156             return i;
1157         }
1158     }
1159     return i;
1160 }
1161
1162 STATIC I32
1163 S_dopoptoeval(pTHX_ I32 startingblock)
1164 {
1165     dTHR;
1166     I32 i;
1167     register PERL_CONTEXT *cx;
1168     for (i = startingblock; i >= 0; i--) {
1169         cx = &cxstack[i];
1170         switch (CxTYPE(cx)) {
1171         default:
1172             continue;
1173         case CXt_EVAL:
1174             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1175             return i;
1176         }
1177     }
1178     return i;
1179 }
1180
1181 STATIC I32
1182 S_dopoptoloop(pTHX_ I32 startingblock)
1183 {
1184     dTHR;
1185     I32 i;
1186     register PERL_CONTEXT *cx;
1187     for (i = startingblock; i >= 0; i--) {
1188         cx = &cxstack[i];
1189         switch (CxTYPE(cx)) {
1190         case CXt_SUBST:
1191             if (ckWARN(WARN_UNSAFE))
1192                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1193                         PL_op_name[PL_op->op_type]);
1194             break;
1195         case CXt_SUB:
1196             if (ckWARN(WARN_UNSAFE))
1197                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1198                         PL_op_name[PL_op->op_type]);
1199             break;
1200         case CXt_FORMAT:
1201             if (ckWARN(WARN_UNSAFE))
1202                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1203                         PL_op_name[PL_op->op_type]);
1204             break;
1205         case CXt_EVAL:
1206             if (ckWARN(WARN_UNSAFE))
1207                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1208                         PL_op_name[PL_op->op_type]);
1209             break;
1210         case CXt_NULL:
1211             if (ckWARN(WARN_UNSAFE))
1212                 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1213                         PL_op_name[PL_op->op_type]);
1214             return -1;
1215         case CXt_LOOP:
1216             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1217             return i;
1218         }
1219     }
1220     return i;
1221 }
1222
1223 void
1224 Perl_dounwind(pTHX_ I32 cxix)
1225 {
1226     dTHR;
1227     register PERL_CONTEXT *cx;
1228     SV **newsp;
1229     I32 optype;
1230
1231     while (cxstack_ix > cxix) {
1232         SV *sv;
1233         cx = &cxstack[cxstack_ix];
1234         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1235                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1236         /* Note: we don't need to restore the base context info till the end. */
1237         switch (CxTYPE(cx)) {
1238         case CXt_SUBST:
1239             POPSUBST(cx);
1240             continue;  /* not break */
1241         case CXt_SUB:
1242             POPSUB(cx,sv);
1243             LEAVESUB(sv);
1244             break;
1245         case CXt_EVAL:
1246             POPEVAL(cx);
1247             break;
1248         case CXt_LOOP:
1249             POPLOOP(cx);
1250             break;
1251         case CXt_NULL:
1252             break;
1253         case CXt_FORMAT:
1254             POPFORMAT(cx);
1255             break;
1256         }
1257         cxstack_ix--;
1258     }
1259 }
1260
1261 /*
1262  * Closures mentioned at top level of eval cannot be referenced
1263  * again, and their presence indirectly causes a memory leak.
1264  * (Note that the fact that compcv and friends are still set here
1265  * is, AFAIK, an accident.)  --Chip
1266  *
1267  * XXX need to get comppad et al from eval's cv rather than
1268  * relying on the incidental global values.
1269  */
1270 STATIC void
1271 S_free_closures(pTHX)
1272 {
1273     dTHR;
1274     SV **svp = AvARRAY(PL_comppad_name);
1275     I32 ix;
1276     for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1277         SV *sv = svp[ix];
1278         if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1279             SvREFCNT_dec(sv);
1280             svp[ix] = &PL_sv_undef;
1281
1282             sv = PL_curpad[ix];
1283             if (CvCLONE(sv)) {
1284                 SvREFCNT_dec(CvOUTSIDE(sv));
1285                 CvOUTSIDE(sv) = Nullcv;
1286             }
1287             else {
1288                 SvREFCNT_dec(sv);
1289                 sv = NEWSV(0,0);
1290                 SvPADTMP_on(sv);
1291                 PL_curpad[ix] = sv;
1292             }
1293         }
1294     }
1295 }
1296
1297 void
1298 Perl_qerror(pTHX_ SV *err)
1299 {
1300     if (PL_in_eval)
1301         sv_catsv(ERRSV, err);
1302     else if (PL_errors)
1303         sv_catsv(PL_errors, err);
1304     else
1305         Perl_warn(aTHX_ "%_", err);
1306     ++PL_error_count;
1307 }
1308
1309 OP *
1310 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1311 {
1312     dSP;
1313     STRLEN n_a;
1314     if (PL_in_eval) {
1315         I32 cxix;
1316         register PERL_CONTEXT *cx;
1317         I32 gimme;
1318         SV **newsp;
1319
1320         if (message) {
1321             if (PL_in_eval & EVAL_KEEPERR) {
1322                 static char prefix[] = "\t(in cleanup) ";
1323                 SV *err = ERRSV;
1324                 char *e = Nullch;
1325                 if (!SvPOK(err))
1326                     sv_setpv(err,"");
1327                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1328                     e = SvPV(err, n_a);
1329                     e += n_a - msglen;
1330                     if (*e != *message || strNE(e,message))
1331                         e = Nullch;
1332                 }
1333                 if (!e) {
1334                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1335                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1336                     sv_catpvn(err, message, msglen);
1337                     if (ckWARN(WARN_UNSAFE)) {
1338                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1339                         Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
1340                     }
1341                 }
1342             }
1343             else
1344                 sv_setpvn(ERRSV, message, msglen);
1345         }
1346         else
1347             message = SvPVx(ERRSV, msglen);
1348
1349         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1350                && PL_curstackinfo->si_prev)
1351         {
1352             dounwind(-1);
1353             POPSTACK;
1354         }
1355
1356         if (cxix >= 0) {
1357             I32 optype;
1358
1359             if (cxix < cxstack_ix)
1360                 dounwind(cxix);
1361
1362             POPBLOCK(cx,PL_curpm);
1363             if (CxTYPE(cx) != CXt_EVAL) {
1364                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1365                 PerlIO_write(Perl_error_log, message, msglen);
1366                 my_exit(1);
1367             }
1368             POPEVAL(cx);
1369
1370             if (gimme == G_SCALAR)
1371                 *++newsp = &PL_sv_undef;
1372             PL_stack_sp = newsp;
1373
1374             LEAVE;
1375
1376             if (optype == OP_REQUIRE) {
1377                 char* msg = SvPVx(ERRSV, n_a);
1378                 DIE(aTHX_ "%sCompilation failed in require",
1379                     *msg ? msg : "Unknown error\n");
1380             }
1381             return pop_return();
1382         }
1383     }
1384     if (!message)
1385         message = SvPVx(ERRSV, msglen);
1386     {
1387 #ifdef USE_SFIO
1388         /* SFIO can really mess with your errno */
1389         int e = errno;
1390 #endif
1391         PerlIO *serr = Perl_error_log;
1392
1393         PerlIO_write(serr, message, msglen);
1394         (void)PerlIO_flush(serr);
1395 #ifdef USE_SFIO
1396         errno = e;
1397 #endif
1398     }
1399     my_failure_exit();
1400     /* NOTREACHED */
1401     return 0;
1402 }
1403
1404 PP(pp_xor)
1405 {
1406     djSP; dPOPTOPssrl;
1407     if (SvTRUE(left) != SvTRUE(right))
1408         RETSETYES;
1409     else
1410         RETSETNO;
1411 }
1412
1413 PP(pp_andassign)
1414 {
1415     djSP;
1416     if (!SvTRUE(TOPs))
1417         RETURN;
1418     else
1419         RETURNOP(cLOGOP->op_other);
1420 }
1421
1422 PP(pp_orassign)
1423 {
1424     djSP;
1425     if (SvTRUE(TOPs))
1426         RETURN;
1427     else
1428         RETURNOP(cLOGOP->op_other);
1429 }
1430
1431 PP(pp_caller)
1432 {
1433     djSP;
1434     register I32 cxix = dopoptosub(cxstack_ix);
1435     register PERL_CONTEXT *cx;
1436     register PERL_CONTEXT *ccstack = cxstack;
1437     PERL_SI *top_si = PL_curstackinfo;
1438     I32 dbcxix;
1439     I32 gimme;
1440     char *stashname;
1441     SV *sv;
1442     I32 count = 0;
1443
1444     if (MAXARG)
1445         count = POPi;
1446     EXTEND(SP, 7);
1447     for (;;) {
1448         /* we may be in a higher stacklevel, so dig down deeper */
1449         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1450             top_si = top_si->si_prev;
1451             ccstack = top_si->si_cxstack;
1452             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1453         }
1454         if (cxix < 0) {
1455             if (GIMME != G_ARRAY)
1456                 RETPUSHUNDEF;
1457             RETURN;
1458         }
1459         if (PL_DBsub && cxix >= 0 &&
1460                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1461             count++;
1462         if (!count--)
1463             break;
1464         cxix = dopoptosub_at(ccstack, cxix - 1);
1465     }
1466
1467     cx = &ccstack[cxix];
1468     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1469         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1470         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1471            field below is defined for any cx. */
1472         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1473             cx = &ccstack[dbcxix];
1474     }
1475
1476     stashname = CopSTASHPV(cx->blk_oldcop);
1477     if (GIMME != G_ARRAY) {
1478         if (!stashname)
1479             PUSHs(&PL_sv_undef);
1480         else {
1481             dTARGET;
1482             sv_setpv(TARG, stashname);
1483             PUSHs(TARG);
1484         }
1485         RETURN;
1486     }
1487
1488     if (!stashname)
1489         PUSHs(&PL_sv_undef);
1490     else
1491         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1492     PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1493     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1494     if (!MAXARG)
1495         RETURN;
1496     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1497         /* So is ccstack[dbcxix]. */
1498         sv = NEWSV(49, 0);
1499         gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1500         PUSHs(sv_2mortal(sv));
1501         PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1502     }
1503     else {
1504         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1505         PUSHs(sv_2mortal(newSViv(0)));
1506     }
1507     gimme = (I32)cx->blk_gimme;
1508     if (gimme == G_VOID)
1509         PUSHs(&PL_sv_undef);
1510     else
1511         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1512     if (CxTYPE(cx) == CXt_EVAL) {
1513         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1514             PUSHs(cx->blk_eval.cur_text);
1515             PUSHs(&PL_sv_no);
1516         }
1517         else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1518             /* Require, put the name. */
1519             PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1520             PUSHs(&PL_sv_yes);
1521         }
1522     }
1523     else {
1524         PUSHs(&PL_sv_undef);
1525         PUSHs(&PL_sv_undef);
1526     }
1527     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1528         && CopSTASH_eq(PL_curcop, PL_debstash))
1529     {
1530         AV *ary = cx->blk_sub.argarray;
1531         int off = AvARRAY(ary) - AvALLOC(ary);
1532
1533         if (!PL_dbargs) {
1534             GV* tmpgv;
1535             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1536                                 SVt_PVAV)));
1537             GvMULTI_on(tmpgv);
1538             AvREAL_off(PL_dbargs);              /* XXX Should be REIFY */
1539         }
1540
1541         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1542             av_extend(PL_dbargs, AvFILLp(ary) + off);
1543         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1544         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1545     }
1546     /* XXX only hints propagated via op_private are currently
1547      * visible (others are not easily accessible, since they
1548      * use the global PL_hints) */
1549     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1550                              HINT_PRIVATE_MASK)));
1551     RETURN;
1552 }
1553
1554 PP(pp_reset)
1555 {
1556     djSP;
1557     char *tmps;
1558     STRLEN n_a;
1559
1560     if (MAXARG < 1)
1561         tmps = "";
1562     else
1563         tmps = POPpx;
1564     sv_reset(tmps, CopSTASH(PL_curcop));
1565     PUSHs(&PL_sv_yes);
1566     RETURN;
1567 }
1568
1569 PP(pp_lineseq)
1570 {
1571     return NORMAL;
1572 }
1573
1574 PP(pp_dbstate)
1575 {
1576     PL_curcop = (COP*)PL_op;
1577     TAINT_NOT;          /* Each statement is presumed innocent */
1578     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1579     FREETMPS;
1580
1581     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1582     {
1583         djSP;
1584         register CV *cv;
1585         register PERL_CONTEXT *cx;
1586         I32 gimme = G_ARRAY;
1587         I32 hasargs;
1588         GV *gv;
1589
1590         gv = PL_DBgv;
1591         cv = GvCV(gv);
1592         if (!cv)
1593             DIE(aTHX_ "No DB::DB routine defined");
1594
1595         if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1596             return NORMAL;
1597
1598         ENTER;
1599         SAVETMPS;
1600
1601         SAVEI32(PL_debug);
1602         SAVESTACK_POS();
1603         PL_debug = 0;
1604         hasargs = 0;
1605         SPAGAIN;
1606
1607         push_return(PL_op->op_next);
1608         PUSHBLOCK(cx, CXt_SUB, SP);
1609         PUSHSUB(cx);
1610         CvDEPTH(cv)++;
1611         (void)SvREFCNT_inc(cv);
1612         SAVEVPTR(PL_curpad);
1613         PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1614         RETURNOP(CvSTART(cv));
1615     }
1616     else
1617         return NORMAL;
1618 }
1619
1620 PP(pp_scope)
1621 {
1622     return NORMAL;
1623 }
1624
1625 PP(pp_enteriter)
1626 {
1627     djSP; dMARK;
1628     register PERL_CONTEXT *cx;
1629     I32 gimme = GIMME_V;
1630     SV **svp;
1631     U32 cxtype = CXt_LOOP;
1632 #ifdef USE_ITHREADS
1633     void *iterdata;
1634 #endif
1635
1636     ENTER;
1637     SAVETMPS;
1638
1639 #ifdef USE_THREADS
1640     if (PL_op->op_flags & OPf_SPECIAL) {
1641         dTHR;
1642         svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
1643         SAVEGENERICSV(*svp);
1644         *svp = NEWSV(0,0);
1645     }
1646     else
1647 #endif /* USE_THREADS */
1648     if (PL_op->op_targ) {
1649         svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1650         SAVESPTR(*svp);
1651 #ifdef USE_ITHREADS
1652         iterdata = (void*)PL_op->op_targ;
1653         cxtype |= CXp_PADVAR;
1654 #endif
1655     }
1656     else {
1657         GV *gv = (GV*)POPs;
1658         svp = &GvSV(gv);                        /* symbol table variable */
1659         SAVEGENERICSV(*svp);
1660         *svp = NEWSV(0,0);
1661 #ifdef USE_ITHREADS
1662         iterdata = (void*)gv;
1663 #endif
1664     }
1665
1666     ENTER;
1667
1668     PUSHBLOCK(cx, cxtype, SP);
1669 #ifdef USE_ITHREADS
1670     PUSHLOOP(cx, iterdata, MARK);
1671 #else
1672     PUSHLOOP(cx, svp, MARK);
1673 #endif
1674     if (PL_op->op_flags & OPf_STACKED) {
1675         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1676         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1677             dPOPss;
1678             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1679                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1680                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1681                  looks_like_number((SV*)cx->blk_loop.iterary) &&
1682                  *SvPVX(cx->blk_loop.iterary) != '0'))
1683             {
1684                  if (SvNV(sv) < IV_MIN ||
1685                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1686                      DIE(aTHX_ "Range iterator outside integer range");
1687                  cx->blk_loop.iterix = SvIV(sv);
1688                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1689             }
1690             else
1691                 cx->blk_loop.iterlval = newSVsv(sv);
1692         }
1693     }
1694     else {
1695         cx->blk_loop.iterary = PL_curstack;
1696         AvFILLp(PL_curstack) = SP - PL_stack_base;
1697         cx->blk_loop.iterix = MARK - PL_stack_base;
1698     }
1699
1700     RETURN;
1701 }
1702
1703 PP(pp_enterloop)
1704 {
1705     djSP;
1706     register PERL_CONTEXT *cx;
1707     I32 gimme = GIMME_V;
1708
1709     ENTER;
1710     SAVETMPS;
1711     ENTER;
1712
1713     PUSHBLOCK(cx, CXt_LOOP, SP);
1714     PUSHLOOP(cx, 0, SP);
1715
1716     RETURN;
1717 }
1718
1719 PP(pp_leaveloop)
1720 {
1721     djSP;
1722     register PERL_CONTEXT *cx;
1723     I32 gimme;
1724     SV **newsp;
1725     PMOP *newpm;
1726     SV **mark;
1727
1728     POPBLOCK(cx,newpm);
1729     mark = newsp;
1730     newsp = PL_stack_base + cx->blk_loop.resetsp;
1731
1732     TAINT_NOT;
1733     if (gimme == G_VOID)
1734         ; /* do nothing */
1735     else if (gimme == G_SCALAR) {
1736         if (mark < SP)
1737             *++newsp = sv_mortalcopy(*SP);
1738         else
1739             *++newsp = &PL_sv_undef;
1740     }
1741     else {
1742         while (mark < SP) {
1743             *++newsp = sv_mortalcopy(*++mark);
1744             TAINT_NOT;          /* Each item is independent */
1745         }
1746     }
1747     SP = newsp;
1748     PUTBACK;
1749
1750     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1751     PL_curpm = newpm;   /* ... and pop $1 et al */
1752
1753     LEAVE;
1754     LEAVE;
1755
1756     return NORMAL;
1757 }
1758
1759 PP(pp_return)
1760 {
1761     djSP; dMARK;
1762     I32 cxix;
1763     register PERL_CONTEXT *cx;
1764     bool popsub2 = FALSE;
1765     I32 gimme;
1766     SV **newsp;
1767     PMOP *newpm;
1768     I32 optype = 0;
1769     SV *sv;
1770
1771     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1772         if (cxstack_ix == PL_sortcxix
1773             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1774         {
1775             if (cxstack_ix > PL_sortcxix)
1776                 dounwind(PL_sortcxix);
1777             AvARRAY(PL_curstack)[1] = *SP;
1778             PL_stack_sp = PL_stack_base + 1;
1779             return 0;
1780         }
1781     }
1782
1783     cxix = dopoptosub(cxstack_ix);
1784     if (cxix < 0)
1785         DIE(aTHX_ "Can't return outside a subroutine");
1786     if (cxix < cxstack_ix)
1787         dounwind(cxix);
1788
1789     POPBLOCK(cx,newpm);
1790     switch (CxTYPE(cx)) {
1791     case CXt_SUB:
1792         popsub2 = TRUE;
1793         break;
1794     case CXt_EVAL:
1795         POPEVAL(cx);
1796         if (AvFILLp(PL_comppad_name) >= 0)
1797             free_closures();
1798         lex_end();
1799         if (optype == OP_REQUIRE &&
1800             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1801         {
1802             /* Unassume the success we assumed earlier. */
1803             char *name = cx->blk_eval.old_name;
1804             (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1805             DIE(aTHX_ "%s did not return a true value", name);
1806         }
1807         break;
1808     case CXt_FORMAT:
1809         POPFORMAT(cx);
1810         break;
1811     default:
1812         DIE(aTHX_ "panic: return");
1813     }
1814
1815     TAINT_NOT;
1816     if (gimme == G_SCALAR) {
1817         if (MARK < SP) {
1818             if (popsub2) {
1819                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1820                     if (SvTEMP(TOPs)) {
1821                         *++newsp = SvREFCNT_inc(*SP);
1822                         FREETMPS;
1823                         sv_2mortal(*newsp);
1824                     } else {
1825                         FREETMPS;
1826                         *++newsp = sv_mortalcopy(*SP);
1827                     }
1828                 } else
1829                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1830             } else
1831                 *++newsp = sv_mortalcopy(*SP);
1832         } else
1833             *++newsp = &PL_sv_undef;
1834     }
1835     else if (gimme == G_ARRAY) {
1836         while (++MARK <= SP) {
1837             *++newsp = (popsub2 && SvTEMP(*MARK))
1838                         ? *MARK : sv_mortalcopy(*MARK);
1839             TAINT_NOT;          /* Each item is independent */
1840         }
1841     }
1842     PL_stack_sp = newsp;
1843
1844     /* Stack values are safe: */
1845     if (popsub2) {
1846         POPSUB(cx,sv);  /* release CV and @_ ... */
1847     }
1848     else
1849         sv = Nullsv;
1850     PL_curpm = newpm;   /* ... and pop $1 et al */
1851
1852     LEAVE;
1853     LEAVESUB(sv);
1854     return pop_return();
1855 }
1856
1857 PP(pp_last)
1858 {
1859     djSP;
1860     I32 cxix;
1861     register PERL_CONTEXT *cx;
1862     I32 pop2 = 0;
1863     I32 gimme;
1864     I32 optype;
1865     OP *nextop;
1866     SV **newsp;
1867     PMOP *newpm;
1868     SV **mark;
1869     SV *sv = Nullsv;
1870
1871     if (PL_op->op_flags & OPf_SPECIAL) {
1872         cxix = dopoptoloop(cxstack_ix);
1873         if (cxix < 0)
1874             DIE(aTHX_ "Can't \"last\" outside a loop block");
1875     }
1876     else {
1877         cxix = dopoptolabel(cPVOP->op_pv);
1878         if (cxix < 0)
1879             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1880     }
1881     if (cxix < cxstack_ix)
1882         dounwind(cxix);
1883
1884     POPBLOCK(cx,newpm);
1885     mark = newsp;
1886     switch (CxTYPE(cx)) {
1887     case CXt_LOOP:
1888         pop2 = CXt_LOOP;
1889         newsp = PL_stack_base + cx->blk_loop.resetsp;
1890         nextop = cx->blk_loop.last_op->op_next;
1891         break;
1892     case CXt_SUB:
1893         pop2 = CXt_SUB;
1894         nextop = pop_return();
1895         break;
1896     case CXt_EVAL:
1897         POPEVAL(cx);
1898         nextop = pop_return();
1899         break;
1900     case CXt_FORMAT:
1901         POPFORMAT(cx);
1902         nextop = pop_return();
1903         break;
1904     default:
1905         DIE(aTHX_ "panic: last");
1906     }
1907
1908     TAINT_NOT;
1909     if (gimme == G_SCALAR) {
1910         if (MARK < SP)
1911             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1912                         ? *SP : sv_mortalcopy(*SP);
1913         else
1914             *++newsp = &PL_sv_undef;
1915     }
1916     else if (gimme == G_ARRAY) {
1917         while (++MARK <= SP) {
1918             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1919                         ? *MARK : sv_mortalcopy(*MARK);
1920             TAINT_NOT;          /* Each item is independent */
1921         }
1922     }
1923     SP = newsp;
1924     PUTBACK;
1925
1926     /* Stack values are safe: */
1927     switch (pop2) {
1928     case CXt_LOOP:
1929         POPLOOP(cx);    /* release loop vars ... */
1930         LEAVE;
1931         break;
1932     case CXt_SUB:
1933         POPSUB(cx,sv);  /* release CV and @_ ... */
1934         break;
1935     }
1936     PL_curpm = newpm;   /* ... and pop $1 et al */
1937
1938     LEAVE;
1939     LEAVESUB(sv);
1940     return nextop;
1941 }
1942
1943 PP(pp_next)
1944 {
1945     I32 cxix;
1946     register PERL_CONTEXT *cx;
1947     I32 oldsave;
1948
1949     if (PL_op->op_flags & OPf_SPECIAL) {
1950         cxix = dopoptoloop(cxstack_ix);
1951         if (cxix < 0)
1952             DIE(aTHX_ "Can't \"next\" outside a loop block");
1953     }
1954     else {
1955         cxix = dopoptolabel(cPVOP->op_pv);
1956         if (cxix < 0)
1957             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1958     }
1959     if (cxix < cxstack_ix)
1960         dounwind(cxix);
1961
1962     TOPBLOCK(cx);
1963     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1964     LEAVE_SCOPE(oldsave);
1965     return cx->blk_loop.next_op;
1966 }
1967
1968 PP(pp_redo)
1969 {
1970     I32 cxix;
1971     register PERL_CONTEXT *cx;
1972     I32 oldsave;
1973
1974     if (PL_op->op_flags & OPf_SPECIAL) {
1975         cxix = dopoptoloop(cxstack_ix);
1976         if (cxix < 0)
1977             DIE(aTHX_ "Can't \"redo\" outside a loop block");
1978     }
1979     else {
1980         cxix = dopoptolabel(cPVOP->op_pv);
1981         if (cxix < 0)
1982             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1983     }
1984     if (cxix < cxstack_ix)
1985         dounwind(cxix);
1986
1987     TOPBLOCK(cx);
1988     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1989     LEAVE_SCOPE(oldsave);
1990     return cx->blk_loop.redo_op;
1991 }
1992
1993 STATIC OP *
1994 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1995 {
1996     OP *kid;
1997     OP **ops = opstack;
1998     static char too_deep[] = "Target of goto is too deeply nested";
1999
2000     if (ops >= oplimit)
2001         Perl_croak(aTHX_ too_deep);
2002     if (o->op_type == OP_LEAVE ||
2003         o->op_type == OP_SCOPE ||
2004         o->op_type == OP_LEAVELOOP ||
2005         o->op_type == OP_LEAVETRY)
2006     {
2007         *ops++ = cUNOPo->op_first;
2008         if (ops >= oplimit)
2009             Perl_croak(aTHX_ too_deep);
2010     }
2011     *ops = 0;
2012     if (o->op_flags & OPf_KIDS) {
2013         dTHR;
2014         /* First try all the kids at this level, since that's likeliest. */
2015         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2016             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2017                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2018                 return kid;
2019         }
2020         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2021             if (kid == PL_lastgotoprobe)
2022                 continue;
2023             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2024                 (ops == opstack ||
2025                  (ops[-1]->op_type != OP_NEXTSTATE &&
2026                   ops[-1]->op_type != OP_DBSTATE)))
2027                 *ops++ = kid;
2028             if (o = dofindlabel(kid, label, ops, oplimit))
2029                 return o;
2030         }
2031     }
2032     *ops = 0;
2033     return 0;
2034 }
2035
2036 PP(pp_dump)
2037 {
2038     return pp_goto();
2039     /*NOTREACHED*/
2040 }
2041
2042 PP(pp_goto)
2043 {
2044     djSP;
2045     OP *retop = 0;
2046     I32 ix;
2047     register PERL_CONTEXT *cx;
2048 #define GOTO_DEPTH 64
2049     OP *enterops[GOTO_DEPTH];
2050     char *label;
2051     int do_dump = (PL_op->op_type == OP_DUMP);
2052     static char must_have_label[] = "goto must have label";
2053
2054     label = 0;
2055     if (PL_op->op_flags & OPf_STACKED) {
2056         SV *sv = POPs;
2057         STRLEN n_a;
2058
2059         /* This egregious kludge implements goto &subroutine */
2060         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2061             I32 cxix;
2062             register PERL_CONTEXT *cx;
2063             CV* cv = (CV*)SvRV(sv);
2064             SV** mark;
2065             I32 items = 0;
2066             I32 oldsave;
2067
2068         retry:
2069             if (!CvROOT(cv) && !CvXSUB(cv)) {
2070                 GV *gv = CvGV(cv);
2071                 GV *autogv;
2072                 if (gv) {
2073                     SV *tmpstr;
2074                     /* autoloaded stub? */
2075                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2076                         goto retry;
2077                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2078                                           GvNAMELEN(gv), FALSE);
2079                     if (autogv && (cv = GvCV(autogv)))
2080                         goto retry;
2081                     tmpstr = sv_newmortal();
2082                     gv_efullname3(tmpstr, gv, Nullch);
2083                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2084                 }
2085                 DIE(aTHX_ "Goto undefined subroutine");
2086             }
2087
2088             /* First do some returnish stuff. */
2089             cxix = dopoptosub(cxstack_ix);
2090             if (cxix < 0)
2091                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2092             if (cxix < cxstack_ix)
2093                 dounwind(cxix);
2094             TOPBLOCK(cx);
2095             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2096                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2097             mark = PL_stack_sp;
2098             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2099                 /* put @_ back onto stack */
2100                 AV* av = cx->blk_sub.argarray;
2101
2102                 items = AvFILLp(av) + 1;
2103                 PL_stack_sp++;
2104                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2105                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2106                 PL_stack_sp += items;
2107 #ifndef USE_THREADS
2108                 SvREFCNT_dec(GvAV(PL_defgv));
2109                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2110 #endif /* USE_THREADS */
2111                 /* abandon @_ if it got reified */
2112                 if (AvREAL(av)) {
2113                     (void)sv_2mortal((SV*)av);  /* delay until return */
2114                     av = newAV();
2115                     av_extend(av, items-1);
2116                     AvFLAGS(av) = AVf_REIFY;
2117                     PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2118                 }
2119             }
2120             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2121                 AV* av;
2122                 int i;
2123 #ifdef USE_THREADS
2124                 av = (AV*)PL_curpad[0];
2125 #else
2126                 av = GvAV(PL_defgv);
2127 #endif
2128                 items = AvFILLp(av) + 1;
2129                 PL_stack_sp++;
2130                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2131                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2132                 PL_stack_sp += items;
2133             }
2134             if (CxTYPE(cx) == CXt_SUB &&
2135                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2136                 SvREFCNT_dec(cx->blk_sub.cv);
2137             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2138             LEAVE_SCOPE(oldsave);
2139
2140             /* Now do some callish stuff. */
2141             SAVETMPS;
2142             if (CvXSUB(cv)) {
2143 #ifdef PERL_XSUB_OLDSTYLE
2144                 if (CvOLDSTYLE(cv)) {
2145                     I32 (*fp3)(int,int,int);
2146                     while (SP > mark) {
2147                         SP[1] = SP[0];
2148                         SP--;
2149                     }
2150                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2151                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2152                                    mark - PL_stack_base + 1,
2153                                    items);
2154                     SP = PL_stack_base + items;
2155                 }
2156                 else
2157 #endif /* PERL_XSUB_OLDSTYLE */
2158                 {
2159                     SV **newsp;
2160                     I32 gimme;
2161
2162                     PL_stack_sp--;              /* There is no cv arg. */
2163                     /* Push a mark for the start of arglist */
2164                     PUSHMARK(mark);
2165                     (void)(*CvXSUB(cv))(aTHXo_ cv);
2166                     /* Pop the current context like a decent sub should */
2167                     POPBLOCK(cx, PL_curpm);
2168                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2169                 }
2170                 LEAVE;
2171                 return pop_return();
2172             }
2173             else {
2174                 AV* padlist = CvPADLIST(cv);
2175                 SV** svp = AvARRAY(padlist);
2176                 if (CxTYPE(cx) == CXt_EVAL) {
2177                     PL_in_eval = cx->blk_eval.old_in_eval;
2178                     PL_eval_root = cx->blk_eval.old_eval_root;
2179                     cx->cx_type = CXt_SUB;
2180                     cx->blk_sub.hasargs = 0;
2181                 }
2182                 cx->blk_sub.cv = cv;
2183                 cx->blk_sub.olddepth = CvDEPTH(cv);
2184                 CvDEPTH(cv)++;
2185                 if (CvDEPTH(cv) < 2)
2186                     (void)SvREFCNT_inc(cv);
2187                 else {  /* save temporaries on recursion? */
2188                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2189                         sub_crush_depth(cv);
2190                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2191                         AV *newpad = newAV();
2192                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2193                         I32 ix = AvFILLp((AV*)svp[1]);
2194                         I32 names_fill = AvFILLp((AV*)svp[0]);
2195                         svp = AvARRAY(svp[0]);
2196                         for ( ;ix > 0; ix--) {
2197                             if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2198                                 char *name = SvPVX(svp[ix]);
2199                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2200                                     || *name == '&')
2201                                 {
2202                                     /* outer lexical or anon code */
2203                                     av_store(newpad, ix,
2204                                         SvREFCNT_inc(oldpad[ix]) );
2205                                 }
2206                                 else {          /* our own lexical */
2207                                     if (*name == '@')
2208                                         av_store(newpad, ix, sv = (SV*)newAV());
2209                                     else if (*name == '%')
2210                                         av_store(newpad, ix, sv = (SV*)newHV());
2211                                     else
2212                                         av_store(newpad, ix, sv = NEWSV(0,0));
2213                                     SvPADMY_on(sv);
2214                                 }
2215                             }
2216                             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2217                                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2218                             }
2219                             else {
2220                                 av_store(newpad, ix, sv = NEWSV(0,0));
2221                                 SvPADTMP_on(sv);
2222                             }
2223                         }
2224                         if (cx->blk_sub.hasargs) {
2225                             AV* av = newAV();
2226                             av_extend(av, 0);
2227                             av_store(newpad, 0, (SV*)av);
2228                             AvFLAGS(av) = AVf_REIFY;
2229                         }
2230                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2231                         AvFILLp(padlist) = CvDEPTH(cv);
2232                         svp = AvARRAY(padlist);
2233                     }
2234                 }
2235 #ifdef USE_THREADS
2236                 if (!cx->blk_sub.hasargs) {
2237                     AV* av = (AV*)PL_curpad[0];
2238
2239                     items = AvFILLp(av) + 1;
2240                     if (items) {
2241                         /* Mark is at the end of the stack. */
2242                         EXTEND(SP, items);
2243                         Copy(AvARRAY(av), SP + 1, items, SV*);
2244                         SP += items;
2245                         PUTBACK ;
2246                     }
2247                 }
2248 #endif /* USE_THREADS */
2249                 SAVEVPTR(PL_curpad);
2250                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2251 #ifndef USE_THREADS
2252                 if (cx->blk_sub.hasargs)
2253 #endif /* USE_THREADS */
2254                 {
2255                     AV* av = (AV*)PL_curpad[0];
2256                     SV** ary;
2257
2258 #ifndef USE_THREADS
2259                     cx->blk_sub.savearray = GvAV(PL_defgv);
2260                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2261 #endif /* USE_THREADS */
2262                     cx->blk_sub.argarray = av;
2263                     ++mark;
2264
2265                     if (items >= AvMAX(av) + 1) {
2266                         ary = AvALLOC(av);
2267                         if (AvARRAY(av) != ary) {
2268                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2269                             SvPVX(av) = (char*)ary;
2270                         }
2271                         if (items >= AvMAX(av) + 1) {
2272                             AvMAX(av) = items - 1;
2273                             Renew(ary,items+1,SV*);
2274                             AvALLOC(av) = ary;
2275                             SvPVX(av) = (char*)ary;
2276                         }
2277                     }
2278                     Copy(mark,AvARRAY(av),items,SV*);
2279                     AvFILLp(av) = items - 1;
2280                     assert(!AvREAL(av));
2281                     while (items--) {
2282                         if (*mark)
2283                             SvTEMP_off(*mark);
2284                         mark++;
2285                     }
2286                 }
2287                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2288                     /*
2289                      * We do not care about using sv to call CV;
2290                      * it's for informational purposes only.
2291                      */
2292                     SV *sv = GvSV(PL_DBsub);
2293                     CV *gotocv;
2294
2295                     if (PERLDB_SUB_NN) {
2296                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2297                     } else {
2298                         save_item(sv);
2299                         gv_efullname3(sv, CvGV(cv), Nullch);
2300                     }
2301                     if (  PERLDB_GOTO
2302                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2303                         PUSHMARK( PL_stack_sp );
2304                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2305                         PL_stack_sp--;
2306                     }
2307                 }
2308                 RETURNOP(CvSTART(cv));
2309             }
2310         }
2311         else {
2312             label = SvPV(sv,n_a);
2313             if (!(do_dump || *label))
2314                 DIE(aTHX_ must_have_label);
2315         }
2316     }
2317     else if (PL_op->op_flags & OPf_SPECIAL) {
2318         if (! do_dump)
2319             DIE(aTHX_ must_have_label);
2320     }
2321     else
2322         label = cPVOP->op_pv;
2323
2324     if (label && *label) {
2325         OP *gotoprobe = 0;
2326
2327         /* find label */
2328
2329         PL_lastgotoprobe = 0;
2330         *enterops = 0;
2331         for (ix = cxstack_ix; ix >= 0; ix--) {
2332             cx = &cxstack[ix];
2333             switch (CxTYPE(cx)) {
2334             case CXt_EVAL:
2335                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2336                 break;
2337             case CXt_LOOP:
2338                 gotoprobe = cx->blk_oldcop->op_sibling;
2339                 break;
2340             case CXt_SUBST:
2341                 continue;
2342             case CXt_BLOCK:
2343                 if (ix)
2344                     gotoprobe = cx->blk_oldcop->op_sibling;
2345                 else
2346                     gotoprobe = PL_main_root;
2347                 break;
2348             case CXt_SUB:
2349                 if (CvDEPTH(cx->blk_sub.cv)) {
2350                     gotoprobe = CvROOT(cx->blk_sub.cv);
2351                     break;
2352                 }
2353                 /* FALL THROUGH */
2354             case CXt_FORMAT:
2355             case CXt_NULL:
2356                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2357             default:
2358                 if (ix)
2359                     DIE(aTHX_ "panic: goto");
2360                 gotoprobe = PL_main_root;
2361                 break;
2362             }
2363             retop = dofindlabel(gotoprobe, label,
2364                                 enterops, enterops + GOTO_DEPTH);
2365             if (retop)
2366                 break;
2367             PL_lastgotoprobe = gotoprobe;
2368         }
2369         if (!retop)
2370             DIE(aTHX_ "Can't find label %s", label);
2371
2372         /* pop unwanted frames */
2373
2374         if (ix < cxstack_ix) {
2375             I32 oldsave;
2376
2377             if (ix < 0)
2378                 ix = 0;
2379             dounwind(ix);
2380             TOPBLOCK(cx);
2381             oldsave = PL_scopestack[PL_scopestack_ix];
2382             LEAVE_SCOPE(oldsave);
2383         }
2384
2385         /* push wanted frames */
2386
2387         if (*enterops && enterops[1]) {
2388             OP *oldop = PL_op;
2389             for (ix = 1; enterops[ix]; ix++) {
2390                 PL_op = enterops[ix];
2391                 /* Eventually we may want to stack the needed arguments
2392                  * for each op.  For now, we punt on the hard ones. */
2393                 if (PL_op->op_type == OP_ENTERITER)
2394                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2395                         label);
2396                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2397             }
2398             PL_op = oldop;
2399         }
2400     }
2401
2402     if (do_dump) {
2403 #ifdef VMS
2404         if (!retop) retop = PL_main_start;
2405 #endif
2406         PL_restartop = retop;
2407         PL_do_undump = TRUE;
2408
2409         my_unexec();
2410
2411         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2412         PL_do_undump = FALSE;
2413     }
2414
2415     RETURNOP(retop);
2416 }
2417
2418 PP(pp_exit)
2419 {
2420     djSP;
2421     I32 anum;
2422
2423     if (MAXARG < 1)
2424         anum = 0;
2425     else {
2426         anum = SvIVx(POPs);
2427 #ifdef VMSISH_EXIT
2428         if (anum == 1 && VMSISH_EXIT)
2429             anum = 0;
2430 #endif
2431     }
2432     PL_exit_flags |= PERL_EXIT_EXPECTED;
2433     my_exit(anum);
2434     PUSHs(&PL_sv_undef);
2435     RETURN;
2436 }
2437
2438 #ifdef NOTYET
2439 PP(pp_nswitch)
2440 {
2441     djSP;
2442     NV value = SvNVx(GvSV(cCOP->cop_gv));
2443     register I32 match = I_32(value);
2444
2445     if (value < 0.0) {
2446         if (((NV)match) > value)
2447             --match;            /* was fractional--truncate other way */
2448     }
2449     match -= cCOP->uop.scop.scop_offset;
2450     if (match < 0)
2451         match = 0;
2452     else if (match > cCOP->uop.scop.scop_max)
2453         match = cCOP->uop.scop.scop_max;
2454     PL_op = cCOP->uop.scop.scop_next[match];
2455     RETURNOP(PL_op);
2456 }
2457
2458 PP(pp_cswitch)
2459 {
2460     djSP;
2461     register I32 match;
2462
2463     if (PL_multiline)
2464         PL_op = PL_op->op_next;                 /* can't assume anything */
2465     else {
2466         STRLEN n_a;
2467         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2468         match -= cCOP->uop.scop.scop_offset;
2469         if (match < 0)
2470             match = 0;
2471         else if (match > cCOP->uop.scop.scop_max)
2472             match = cCOP->uop.scop.scop_max;
2473         PL_op = cCOP->uop.scop.scop_next[match];
2474     }
2475     RETURNOP(PL_op);
2476 }
2477 #endif
2478
2479 /* Eval. */
2480
2481 STATIC void
2482 S_save_lines(pTHX_ AV *array, SV *sv)
2483 {
2484     register char *s = SvPVX(sv);
2485     register char *send = SvPVX(sv) + SvCUR(sv);
2486     register char *t;
2487     register I32 line = 1;
2488
2489     while (s && s < send) {
2490         SV *tmpstr = NEWSV(85,0);
2491
2492         sv_upgrade(tmpstr, SVt_PVMG);
2493         t = strchr(s, '\n');
2494         if (t)
2495             t++;
2496         else
2497             t = send;
2498
2499         sv_setpvn(tmpstr, s, t - s);
2500         av_store(array, line++, tmpstr);
2501         s = t;
2502     }
2503 }
2504
2505 STATIC void *
2506 S_docatch_body(pTHX_ va_list args)
2507 {
2508     CALLRUNOPS(aTHX);
2509     return NULL;
2510 }
2511
2512 STATIC OP *
2513 S_docatch(pTHX_ OP *o)
2514 {
2515     dTHR;
2516     int ret;
2517     OP *oldop = PL_op;
2518     volatile PERL_SI *cursi = PL_curstackinfo;
2519     dJMPENV;
2520
2521 #ifdef DEBUGGING
2522     assert(CATCH_GET == TRUE);
2523 #endif
2524     PL_op = o;
2525  redo_body:
2526     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2527     switch (ret) {
2528     case 0:
2529         break;
2530     case 3:
2531         if (PL_restartop && cursi == PL_curstackinfo) {
2532             PL_op = PL_restartop;
2533             PL_restartop = 0;
2534             goto redo_body;
2535         }
2536         /* FALL THROUGH */
2537     default:
2538         PL_op = oldop;
2539         JMPENV_JUMP(ret);
2540         /* NOTREACHED */
2541     }
2542     PL_op = oldop;
2543     return Nullop;
2544 }
2545
2546 OP *
2547 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2548 /* sv Text to convert to OP tree. */
2549 /* startop op_free() this to undo. */
2550 /* code Short string id of the caller. */
2551 {
2552     dSP;                                /* Make POPBLOCK work. */
2553     PERL_CONTEXT *cx;
2554     SV **newsp;
2555     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2556     I32 optype;
2557     OP dummy;
2558     OP *oop = PL_op, *rop;
2559     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2560     char *safestr;
2561
2562     ENTER;
2563     lex_start(sv);
2564     SAVETMPS;
2565     /* switch to eval mode */
2566
2567     if (PL_curcop == &PL_compiling) {
2568         SAVECOPSTASH(&PL_compiling);
2569         CopSTASH_set(&PL_compiling, PL_curstash);
2570     }
2571     SAVECOPFILE(&PL_compiling);
2572     SAVECOPLINE(&PL_compiling);
2573     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2574     CopFILE_set(&PL_compiling, tmpbuf+2);
2575     CopLINE_set(&PL_compiling, 1);
2576     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2577        deleting the eval's FILEGV from the stash before gv_check() runs
2578        (i.e. before run-time proper). To work around the coredump that
2579        ensues, we always turn GvMULTI_on for any globals that were
2580        introduced within evals. See force_ident(). GSAR 96-10-12 */
2581     safestr = savepv(tmpbuf);
2582     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2583     SAVEHINTS();
2584 #ifdef OP_IN_REGISTER
2585     PL_opsave = op;
2586 #else
2587     SAVEVPTR(PL_op);
2588 #endif
2589     PL_hints = 0;
2590
2591     PL_op = &dummy;
2592     PL_op->op_type = OP_ENTEREVAL;
2593     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2594     PUSHBLOCK(cx, CXt_EVAL, SP);
2595     PUSHEVAL(cx, 0, Nullgv);
2596     rop = doeval(G_SCALAR, startop);
2597     POPBLOCK(cx,PL_curpm);
2598     POPEVAL(cx);
2599
2600     (*startop)->op_type = OP_NULL;
2601     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2602     lex_end();
2603     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2604     LEAVE;
2605     if (PL_curcop == &PL_compiling)
2606         PL_compiling.op_private = PL_hints;
2607 #ifdef OP_IN_REGISTER
2608     op = PL_opsave;
2609 #endif
2610     return rop;
2611 }
2612
2613 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2614 STATIC OP *
2615 S_doeval(pTHX_ int gimme, OP** startop)
2616 {
2617     dSP;
2618     OP *saveop = PL_op;
2619     CV *caller;
2620     AV* comppadlist;
2621     I32 i;
2622
2623     PL_in_eval = EVAL_INEVAL;
2624
2625     PUSHMARK(SP);
2626
2627     /* set up a scratch pad */
2628
2629     SAVEI32(PL_padix);
2630     SAVEVPTR(PL_curpad);
2631     SAVESPTR(PL_comppad);
2632     SAVESPTR(PL_comppad_name);
2633     SAVEI32(PL_comppad_name_fill);
2634     SAVEI32(PL_min_intro_pending);
2635     SAVEI32(PL_max_intro_pending);
2636
2637     caller = PL_compcv;
2638     for (i = cxstack_ix - 1; i >= 0; i--) {
2639         PERL_CONTEXT *cx = &cxstack[i];
2640         if (CxTYPE(cx) == CXt_EVAL)
2641             break;
2642         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2643             caller = cx->blk_sub.cv;
2644             break;
2645         }
2646     }
2647
2648     SAVESPTR(PL_compcv);
2649     PL_compcv = (CV*)NEWSV(1104,0);
2650     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2651     CvEVAL_on(PL_compcv);
2652 #ifdef USE_THREADS
2653     CvOWNER(PL_compcv) = 0;
2654     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2655     MUTEX_INIT(CvMUTEXP(PL_compcv));
2656 #endif /* USE_THREADS */
2657
2658     PL_comppad = newAV();
2659     av_push(PL_comppad, Nullsv);
2660     PL_curpad = AvARRAY(PL_comppad);
2661     PL_comppad_name = newAV();
2662     PL_comppad_name_fill = 0;
2663     PL_min_intro_pending = 0;
2664     PL_padix = 0;
2665 #ifdef USE_THREADS
2666     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2667     PL_curpad[0] = (SV*)newAV();
2668     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2669 #endif /* USE_THREADS */
2670
2671     comppadlist = newAV();
2672     AvREAL_off(comppadlist);
2673     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2674     av_store(comppadlist, 1, (SV*)PL_comppad);
2675     CvPADLIST(PL_compcv) = comppadlist;
2676
2677     if (!saveop || saveop->op_type != OP_REQUIRE)
2678         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2679
2680     SAVEFREESV(PL_compcv);
2681
2682     /* make sure we compile in the right package */
2683
2684     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2685         SAVESPTR(PL_curstash);
2686         PL_curstash = CopSTASH(PL_curcop);
2687     }
2688     SAVESPTR(PL_beginav);
2689     PL_beginav = newAV();
2690     SAVEFREESV(PL_beginav);
2691
2692     /* try to compile it */
2693
2694     PL_eval_root = Nullop;
2695     PL_error_count = 0;
2696     PL_curcop = &PL_compiling;
2697     PL_curcop->cop_arybase = 0;
2698     SvREFCNT_dec(PL_rs);
2699     PL_rs = newSVpvn("\n", 1);
2700     if (saveop && saveop->op_flags & OPf_SPECIAL)
2701         PL_in_eval |= EVAL_KEEPERR;
2702     else
2703         sv_setpv(ERRSV,"");
2704     if (yyparse() || PL_error_count || !PL_eval_root) {
2705         SV **newsp;
2706         I32 gimme;
2707         PERL_CONTEXT *cx;
2708         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2709         STRLEN n_a;
2710
2711         PL_op = saveop;
2712         if (PL_eval_root) {
2713             op_free(PL_eval_root);
2714             PL_eval_root = Nullop;
2715         }
2716         SP = PL_stack_base + POPMARK;           /* pop original mark */
2717         if (!startop) {
2718             POPBLOCK(cx,PL_curpm);
2719             POPEVAL(cx);
2720             pop_return();
2721         }
2722         lex_end();
2723         LEAVE;
2724         if (optype == OP_REQUIRE) {
2725             char* msg = SvPVx(ERRSV, n_a);
2726             DIE(aTHX_ "%sCompilation failed in require",
2727                 *msg ? msg : "Unknown error\n");
2728         }
2729         else if (startop) {
2730             char* msg = SvPVx(ERRSV, n_a);
2731
2732             POPBLOCK(cx,PL_curpm);
2733             POPEVAL(cx);
2734             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2735                        (*msg ? msg : "Unknown error\n"));
2736         }
2737         SvREFCNT_dec(PL_rs);
2738         PL_rs = SvREFCNT_inc(PL_nrs);
2739 #ifdef USE_THREADS
2740         MUTEX_LOCK(&PL_eval_mutex);
2741         PL_eval_owner = 0;
2742         COND_SIGNAL(&PL_eval_cond);
2743         MUTEX_UNLOCK(&PL_eval_mutex);
2744 #endif /* USE_THREADS */
2745         RETPUSHUNDEF;
2746     }
2747     SvREFCNT_dec(PL_rs);
2748     PL_rs = SvREFCNT_inc(PL_nrs);
2749     CopLINE_set(&PL_compiling, 0);
2750     if (startop) {
2751         *startop = PL_eval_root;
2752         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2753         CvOUTSIDE(PL_compcv) = Nullcv;
2754     } else
2755         SAVEFREEOP(PL_eval_root);
2756     if (gimme & G_VOID)
2757         scalarvoid(PL_eval_root);
2758     else if (gimme & G_ARRAY)
2759         list(PL_eval_root);
2760     else
2761         scalar(PL_eval_root);
2762
2763     DEBUG_x(dump_eval());
2764
2765     /* Register with debugger: */
2766     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2767         CV *cv = get_cv("DB::postponed", FALSE);
2768         if (cv) {
2769             dSP;
2770             PUSHMARK(SP);
2771             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2772             PUTBACK;
2773             call_sv((SV*)cv, G_DISCARD);
2774         }
2775     }
2776
2777     /* compiled okay, so do it */
2778
2779     CvDEPTH(PL_compcv) = 1;
2780     SP = PL_stack_base + POPMARK;               /* pop original mark */
2781     PL_op = saveop;                     /* The caller may need it. */
2782 #ifdef USE_THREADS
2783     MUTEX_LOCK(&PL_eval_mutex);
2784     PL_eval_owner = 0;
2785     COND_SIGNAL(&PL_eval_cond);
2786     MUTEX_UNLOCK(&PL_eval_mutex);
2787 #endif /* USE_THREADS */
2788
2789     RETURNOP(PL_eval_start);
2790 }
2791
2792 STATIC PerlIO *
2793 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2794 {
2795     STRLEN namelen = strlen(name);
2796     PerlIO *fp;
2797
2798     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2799         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2800         char *pmc = SvPV_nolen(pmcsv);
2801         Stat_t pmstat;
2802         Stat_t pmcstat;
2803         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2804             fp = PerlIO_open(name, mode);
2805         }
2806         else {
2807             if (PerlLIO_stat(name, &pmstat) < 0 ||
2808                 pmstat.st_mtime < pmcstat.st_mtime)
2809             {
2810                 fp = PerlIO_open(pmc, mode);
2811             }
2812             else {
2813                 fp = PerlIO_open(name, mode);
2814             }
2815         }
2816         SvREFCNT_dec(pmcsv);
2817     }
2818     else {
2819         fp = PerlIO_open(name, mode);
2820     }
2821     return fp;
2822 }
2823
2824 PP(pp_require)
2825 {
2826     djSP;
2827     register PERL_CONTEXT *cx;
2828     SV *sv;
2829     char *name;
2830     STRLEN len;
2831     char *tryname;
2832     SV *namesv = Nullsv;
2833     SV** svp;
2834     I32 gimme = G_SCALAR;
2835     PerlIO *tryrsfp = 0;
2836     STRLEN n_a;
2837     int filter_has_file = 0;
2838     GV *filter_child_proc = 0;
2839     SV *filter_state = 0;
2840     SV *filter_sub = 0;
2841
2842     sv = POPs;
2843     if (SvNIOKp(sv)) {
2844         UV rev, ver, sver;
2845         if (SvPOKp(sv) && SvUTF8(sv)) {         /* require v5.6.1 */
2846             I32 len;
2847             U8 *s = (U8*)SvPVX(sv);
2848             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2849             if (s < end) {
2850                 rev = utf8_to_uv(s, &len);
2851                 s += len;
2852                 if (s < end) {
2853                     ver = utf8_to_uv(s, &len);
2854                     s += len;
2855                     if (s < end)
2856                         sver = utf8_to_uv(s, &len);
2857                     else
2858                         sver = 0;
2859                 }
2860                 else
2861                     ver = 0;
2862             }
2863             else
2864                 rev = 0;
2865             if (PERL_REVISION < rev
2866                 || (PERL_REVISION == rev
2867                     && (PERL_VERSION < ver
2868                         || (PERL_VERSION == ver
2869                             && PERL_SUBVERSION < sver))))
2870             {
2871                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2872                     "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION,
2873                     PERL_VERSION, PERL_SUBVERSION);
2874             }
2875         }
2876         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2877             NV n = SvNV(sv);
2878             rev = (UV)n;
2879             ver = (UV)((n-rev)*1000);
2880             sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
2881
2882             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2883                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2884                 + 0.00000099 < SvNV(sv))
2885             {
2886                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2887                     "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION,
2888                     PERL_VERSION, PERL_SUBVERSION);
2889             }
2890         }
2891         RETPUSHYES;
2892     }
2893     name = SvPV(sv, len);
2894     if (!(name && len > 0 && *name))
2895         DIE(aTHX_ "Null filename used");
2896     TAINT_PROPER("require");
2897     if (PL_op->op_type == OP_REQUIRE &&
2898       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2899       *svp != &PL_sv_undef)
2900         RETPUSHYES;
2901
2902     /* prepare to compile file */
2903
2904     if (PERL_FILE_IS_ABSOLUTE(name)
2905         || (*name == '.' && (name[1] == '/' ||
2906                              (name[1] == '.' && name[2] == '/'))))
2907     {
2908         tryname = name;
2909         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2910     }
2911     else {
2912         AV *ar = GvAVn(PL_incgv);
2913         I32 i;
2914 #ifdef VMS
2915         char *unixname;
2916         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2917 #endif
2918         {
2919             namesv = NEWSV(806, 0);
2920             for (i = 0; i <= AvFILL(ar); i++) {
2921                 SV *dirsv = *av_fetch(ar, i, TRUE);
2922
2923                 if (SvROK(dirsv)) {
2924                     int count;
2925                     SV *loader = dirsv;
2926
2927                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2928                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2929                     }
2930
2931                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2932                                    PTR2UV(SvANY(loader)), name);
2933                     tryname = SvPVX(namesv);
2934                     tryrsfp = 0;
2935
2936                     ENTER;
2937                     SAVETMPS;
2938                     EXTEND(SP, 2);
2939
2940                     PUSHMARK(SP);
2941                     PUSHs(dirsv);
2942                     PUSHs(sv);
2943                     PUTBACK;
2944                     count = call_sv(loader, G_ARRAY);
2945                     SPAGAIN;
2946
2947                     if (count > 0) {
2948                         int i = 0;
2949                         SV *arg;
2950
2951                         SP -= count - 1;
2952                         arg = SP[i++];
2953
2954                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2955                             arg = SvRV(arg);
2956                         }
2957
2958                         if (SvTYPE(arg) == SVt_PVGV) {
2959                             IO *io = GvIO((GV *)arg);
2960
2961                             ++filter_has_file;
2962
2963                             if (io) {
2964                                 tryrsfp = IoIFP(io);
2965                                 if (IoTYPE(io) == '|') {
2966                                     /* reading from a child process doesn't
2967                                        nest -- when returning from reading
2968                                        the inner module, the outer one is
2969                                        unreadable (closed?)  I've tried to
2970                                        save the gv to manage the lifespan of
2971                                        the pipe, but this didn't help. XXX */
2972                                     filter_child_proc = (GV *)arg;
2973                                     (void)SvREFCNT_inc(filter_child_proc);
2974                                 }
2975                                 else {
2976                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2977                                         PerlIO_close(IoOFP(io));
2978                                     }
2979                                     IoIFP(io) = Nullfp;
2980                                     IoOFP(io) = Nullfp;
2981                                 }
2982                             }
2983
2984                             if (i < count) {
2985                                 arg = SP[i++];
2986                             }
2987                         }
2988
2989                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2990                             filter_sub = arg;
2991                             (void)SvREFCNT_inc(filter_sub);
2992
2993                             if (i < count) {
2994                                 filter_state = SP[i];
2995                                 (void)SvREFCNT_inc(filter_state);
2996                             }
2997
2998                             if (tryrsfp == 0) {
2999                                 tryrsfp = PerlIO_open("/dev/null",
3000                                                       PERL_SCRIPT_MODE);
3001                             }
3002                         }
3003                     }
3004
3005                     PUTBACK;
3006                     FREETMPS;
3007                     LEAVE;
3008
3009                     if (tryrsfp) {
3010                         break;
3011                     }
3012
3013                     filter_has_file = 0;
3014                     if (filter_child_proc) {
3015                         SvREFCNT_dec(filter_child_proc);
3016                         filter_child_proc = 0;
3017                     }
3018                     if (filter_state) {
3019                         SvREFCNT_dec(filter_state);
3020                         filter_state = 0;
3021                     }
3022                     if (filter_sub) {
3023                         SvREFCNT_dec(filter_sub);
3024                         filter_sub = 0;
3025                     }
3026                 }
3027                 else {
3028                     char *dir = SvPVx(dirsv, n_a);
3029 #ifdef VMS
3030                     char *unixdir;
3031                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3032                         continue;
3033                     sv_setpv(namesv, unixdir);
3034                     sv_catpv(namesv, unixname);
3035 #else
3036                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3037 #endif
3038                     TAINT_PROPER("require");
3039                     tryname = SvPVX(namesv);
3040                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3041                     if (tryrsfp) {
3042                         if (tryname[0] == '.' && tryname[1] == '/')
3043                             tryname += 2;
3044                         break;
3045                     }
3046                 }
3047             }
3048         }
3049     }
3050     SAVECOPFILE(&PL_compiling);
3051     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3052     SvREFCNT_dec(namesv);
3053     if (!tryrsfp) {
3054         if (PL_op->op_type == OP_REQUIRE) {
3055             char *msgstr = name;
3056             if (namesv) {                       /* did we lookup @INC? */
3057                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3058                 SV *dirmsgsv = NEWSV(0, 0);
3059                 AV *ar = GvAVn(PL_incgv);
3060                 I32 i;
3061                 sv_catpvn(msg, " in @INC", 8);
3062                 if (instr(SvPVX(msg), ".h "))
3063                     sv_catpv(msg, " (change .h to .ph maybe?)");
3064                 if (instr(SvPVX(msg), ".ph "))
3065                     sv_catpv(msg, " (did you run h2ph?)");
3066                 sv_catpv(msg, " (@INC contains:");
3067                 for (i = 0; i <= AvFILL(ar); i++) {
3068                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3069                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3070                     sv_catsv(msg, dirmsgsv);
3071                 }
3072                 sv_catpvn(msg, ")", 1);
3073                 SvREFCNT_dec(dirmsgsv);
3074                 msgstr = SvPV_nolen(msg);
3075             }
3076             DIE(aTHX_ "Can't locate %s", msgstr);
3077         }
3078
3079         RETPUSHUNDEF;
3080     }
3081     else
3082         SETERRNO(0, SS$_NORMAL);
3083
3084     /* Assume success here to prevent recursive requirement. */
3085     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3086                    newSVpv(CopFILE(&PL_compiling), 0), 0 );
3087
3088     ENTER;
3089     SAVETMPS;
3090     lex_start(sv_2mortal(newSVpvn("",0)));
3091     SAVEGENERICSV(PL_rsfp_filters);
3092     PL_rsfp_filters = Nullav;
3093
3094     PL_rsfp = tryrsfp;
3095     SAVEHINTS();
3096     PL_hints = 0;
3097     SAVESPTR(PL_compiling.cop_warnings);
3098     if (PL_dowarn & G_WARN_ALL_ON)
3099         PL_compiling.cop_warnings = WARN_ALL ;
3100     else if (PL_dowarn & G_WARN_ALL_OFF)
3101         PL_compiling.cop_warnings = WARN_NONE ;
3102     else
3103         PL_compiling.cop_warnings = WARN_STD ;
3104
3105     if (filter_sub || filter_child_proc) {
3106         SV *datasv = filter_add(run_user_filter, Nullsv);
3107         IoLINES(datasv) = filter_has_file;
3108         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3109         IoTOP_GV(datasv) = (GV *)filter_state;
3110         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3111     }
3112
3113     /* switch to eval mode */
3114     push_return(PL_op->op_next);
3115     PUSHBLOCK(cx, CXt_EVAL, SP);
3116     PUSHEVAL(cx, name, Nullgv);
3117
3118     SAVECOPLINE(&PL_compiling);
3119     CopLINE_set(&PL_compiling, 0);
3120
3121     PUTBACK;
3122 #ifdef USE_THREADS
3123     MUTEX_LOCK(&PL_eval_mutex);
3124     if (PL_eval_owner && PL_eval_owner != thr)
3125         while (PL_eval_owner)
3126             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3127     PL_eval_owner = thr;
3128     MUTEX_UNLOCK(&PL_eval_mutex);
3129 #endif /* USE_THREADS */
3130     return DOCATCH(doeval(G_SCALAR, NULL));
3131 }
3132
3133 PP(pp_dofile)
3134 {
3135     return pp_require();
3136 }
3137
3138 PP(pp_entereval)
3139 {
3140     djSP;
3141     register PERL_CONTEXT *cx;
3142     dPOPss;
3143     I32 gimme = GIMME_V, was = PL_sub_generation;
3144     char tmpbuf[TYPE_DIGITS(long) + 12];
3145     char *safestr;
3146     STRLEN len;
3147     OP *ret;
3148
3149     if (!SvPV(sv,len) || !len)
3150         RETPUSHUNDEF;
3151     TAINT_PROPER("eval");
3152
3153     ENTER;
3154     lex_start(sv);
3155     SAVETMPS;
3156
3157     /* switch to eval mode */
3158
3159     SAVECOPFILE(&PL_compiling);
3160     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3161     CopFILE_set(&PL_compiling, tmpbuf+2);
3162     CopLINE_set(&PL_compiling, 1);
3163     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3164        deleting the eval's FILEGV from the stash before gv_check() runs
3165        (i.e. before run-time proper). To work around the coredump that
3166        ensues, we always turn GvMULTI_on for any globals that were
3167        introduced within evals. See force_ident(). GSAR 96-10-12 */
3168     safestr = savepv(tmpbuf);
3169     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3170     SAVEHINTS();
3171     PL_hints = PL_op->op_targ;
3172     SAVESPTR(PL_compiling.cop_warnings);
3173     if (!specialWARN(PL_compiling.cop_warnings)) {
3174         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3175         SAVEFREESV(PL_compiling.cop_warnings) ;
3176     }
3177
3178     push_return(PL_op->op_next);
3179     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3180     PUSHEVAL(cx, 0, Nullgv);
3181
3182     /* prepare to compile string */
3183
3184     if (PERLDB_LINE && PL_curstash != PL_debstash)
3185         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3186     PUTBACK;
3187 #ifdef USE_THREADS
3188     MUTEX_LOCK(&PL_eval_mutex);
3189     if (PL_eval_owner && PL_eval_owner != thr)
3190         while (PL_eval_owner)
3191             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3192     PL_eval_owner = thr;
3193     MUTEX_UNLOCK(&PL_eval_mutex);
3194 #endif /* USE_THREADS */
3195     ret = doeval(gimme, NULL);
3196     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3197         && ret != PL_op->op_next) {     /* Successive compilation. */
3198         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3199     }
3200     return DOCATCH(ret);
3201 }
3202
3203 PP(pp_leaveeval)
3204 {
3205     djSP;
3206     register SV **mark;
3207     SV **newsp;
3208     PMOP *newpm;
3209     I32 gimme;
3210     register PERL_CONTEXT *cx;
3211     OP *retop;
3212     U8 save_flags = PL_op -> op_flags;
3213     I32 optype;
3214
3215     POPBLOCK(cx,newpm);
3216     POPEVAL(cx);
3217     retop = pop_return();
3218
3219     TAINT_NOT;
3220     if (gimme == G_VOID)
3221         MARK = newsp;
3222     else if (gimme == G_SCALAR) {
3223         MARK = newsp + 1;
3224         if (MARK <= SP) {
3225             if (SvFLAGS(TOPs) & SVs_TEMP)
3226                 *MARK = TOPs;
3227             else
3228                 *MARK = sv_mortalcopy(TOPs);
3229         }
3230         else {
3231             MEXTEND(mark,0);
3232             *MARK = &PL_sv_undef;
3233         }
3234         SP = MARK;
3235     }
3236     else {
3237         /* in case LEAVE wipes old return values */
3238         for (mark = newsp + 1; mark <= SP; mark++) {
3239             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3240                 *mark = sv_mortalcopy(*mark);
3241                 TAINT_NOT;      /* Each item is independent */
3242             }
3243         }
3244     }
3245     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3246
3247     if (AvFILLp(PL_comppad_name) >= 0)
3248         free_closures();
3249
3250 #ifdef DEBUGGING
3251     assert(CvDEPTH(PL_compcv) == 1);
3252 #endif
3253     CvDEPTH(PL_compcv) = 0;
3254     lex_end();
3255
3256     if (optype == OP_REQUIRE &&
3257         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3258     {
3259         /* Unassume the success we assumed earlier. */
3260         char *name = cx->blk_eval.old_name;
3261         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3262         retop = Perl_die(aTHX_ "%s did not return a true value", name);
3263         /* die_where() did LEAVE, or we won't be here */
3264     }
3265     else {
3266         LEAVE;
3267         if (!(save_flags & OPf_SPECIAL))
3268             sv_setpv(ERRSV,"");
3269     }
3270
3271     RETURNOP(retop);
3272 }
3273
3274 PP(pp_entertry)
3275 {
3276     djSP;
3277     register PERL_CONTEXT *cx;
3278     I32 gimme = GIMME_V;
3279
3280     ENTER;
3281     SAVETMPS;
3282
3283     push_return(cLOGOP->op_other->op_next);
3284     PUSHBLOCK(cx, CXt_EVAL, SP);
3285     PUSHEVAL(cx, 0, 0);
3286     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3287
3288     PL_in_eval = EVAL_INEVAL;
3289     sv_setpv(ERRSV,"");
3290     PUTBACK;
3291     return DOCATCH(PL_op->op_next);
3292 }
3293
3294 PP(pp_leavetry)
3295 {
3296     djSP;
3297     register SV **mark;
3298     SV **newsp;
3299     PMOP *newpm;
3300     I32 gimme;
3301     register PERL_CONTEXT *cx;
3302     I32 optype;
3303
3304     POPBLOCK(cx,newpm);
3305     POPEVAL(cx);
3306     pop_return();
3307
3308     TAINT_NOT;
3309     if (gimme == G_VOID)
3310         SP = newsp;
3311     else if (gimme == G_SCALAR) {
3312         MARK = newsp + 1;
3313         if (MARK <= SP) {
3314             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3315                 *MARK = TOPs;
3316             else
3317                 *MARK = sv_mortalcopy(TOPs);
3318         }
3319         else {
3320             MEXTEND(mark,0);
3321             *MARK = &PL_sv_undef;
3322         }
3323         SP = MARK;
3324     }
3325     else {
3326         /* in case LEAVE wipes old return values */
3327         for (mark = newsp + 1; mark <= SP; mark++) {
3328             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3329                 *mark = sv_mortalcopy(*mark);
3330                 TAINT_NOT;      /* Each item is independent */
3331             }
3332         }
3333     }
3334     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3335
3336     LEAVE;
3337     sv_setpv(ERRSV,"");
3338     RETURN;
3339 }
3340
3341 STATIC void
3342 S_doparseform(pTHX_ SV *sv)
3343 {
3344     STRLEN len;
3345     register char *s = SvPV_force(sv, len);
3346     register char *send = s + len;
3347     register char *base;
3348     register I32 skipspaces = 0;
3349     bool noblank;
3350     bool repeat;
3351     bool postspace = FALSE;
3352     U16 *fops;
3353     register U16 *fpc;
3354     U16 *linepc;
3355     register I32 arg;
3356     bool ischop;
3357
3358     if (len == 0)
3359         Perl_croak(aTHX_ "Null picture in formline");
3360
3361     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3362     fpc = fops;
3363
3364     if (s < send) {
3365         linepc = fpc;
3366         *fpc++ = FF_LINEMARK;
3367         noblank = repeat = FALSE;
3368         base = s;
3369     }
3370
3371     while (s <= send) {
3372         switch (*s++) {
3373         default:
3374             skipspaces = 0;
3375             continue;
3376
3377         case '~':
3378             if (*s == '~') {
3379                 repeat = TRUE;
3380                 *s = ' ';
3381             }
3382             noblank = TRUE;
3383             s[-1] = ' ';
3384             /* FALL THROUGH */
3385         case ' ': case '\t':
3386             skipspaces++;
3387             continue;
3388
3389         case '\n': case 0:
3390             arg = s - base;
3391             skipspaces++;
3392             arg -= skipspaces;
3393             if (arg) {
3394                 if (postspace)
3395                     *fpc++ = FF_SPACE;
3396                 *fpc++ = FF_LITERAL;
3397                 *fpc++ = arg;
3398             }
3399             postspace = FALSE;
3400             if (s <= send)
3401                 skipspaces--;
3402             if (skipspaces) {
3403                 *fpc++ = FF_SKIP;
3404                 *fpc++ = skipspaces;
3405             }
3406             skipspaces = 0;
3407             if (s <= send)
3408                 *fpc++ = FF_NEWLINE;
3409             if (noblank) {
3410                 *fpc++ = FF_BLANK;
3411                 if (repeat)
3412                     arg = fpc - linepc + 1;
3413                 else
3414                     arg = 0;
3415                 *fpc++ = arg;
3416             }
3417             if (s < send) {
3418                 linepc = fpc;
3419                 *fpc++ = FF_LINEMARK;
3420                 noblank = repeat = FALSE;
3421                 base = s;
3422             }
3423             else
3424                 s++;
3425             continue;
3426
3427         case '@':
3428         case '^':
3429             ischop = s[-1] == '^';
3430
3431             if (postspace) {
3432                 *fpc++ = FF_SPACE;
3433                 postspace = FALSE;
3434             }
3435             arg = (s - base) - 1;
3436             if (arg) {
3437                 *fpc++ = FF_LITERAL;
3438                 *fpc++ = arg;
3439             }
3440
3441             base = s - 1;
3442             *fpc++ = FF_FETCH;
3443             if (*s == '*') {
3444                 s++;
3445                 *fpc++ = 0;
3446                 *fpc++ = FF_LINEGLOB;
3447             }
3448             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3449                 arg = ischop ? 512 : 0;
3450                 base = s - 1;
3451                 while (*s == '#')
3452                     s++;
3453                 if (*s == '.') {
3454                     char *f;
3455                     s++;
3456                     f = s;
3457                     while (*s == '#')
3458                         s++;
3459                     arg |= 256 + (s - f);
3460                 }
3461                 *fpc++ = s - base;              /* fieldsize for FETCH */
3462                 *fpc++ = FF_DECIMAL;
3463                 *fpc++ = arg;
3464             }
3465             else {
3466                 I32 prespace = 0;
3467                 bool ismore = FALSE;
3468
3469                 if (*s == '>') {
3470                     while (*++s == '>') ;
3471                     prespace = FF_SPACE;
3472                 }
3473                 else if (*s == '|') {
3474                     while (*++s == '|') ;
3475                     prespace = FF_HALFSPACE;
3476                     postspace = TRUE;
3477                 }
3478                 else {
3479                     if (*s == '<')
3480                         while (*++s == '<') ;
3481                     postspace = TRUE;
3482                 }
3483                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3484                     s += 3;
3485                     ismore = TRUE;
3486                 }
3487                 *fpc++ = s - base;              /* fieldsize for FETCH */
3488
3489                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3490
3491                 if (prespace)
3492                     *fpc++ = prespace;
3493                 *fpc++ = FF_ITEM;
3494                 if (ismore)
3495                     *fpc++ = FF_MORE;
3496                 if (ischop)
3497                     *fpc++ = FF_CHOP;
3498             }
3499             base = s;
3500             skipspaces = 0;
3501             continue;
3502         }
3503     }
3504     *fpc++ = FF_END;
3505
3506     arg = fpc - fops;
3507     { /* need to jump to the next word */
3508         int z;
3509         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3510         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3511         s = SvPVX(sv) + SvCUR(sv) + z;
3512     }
3513     Copy(fops, s, arg, U16);
3514     Safefree(fops);
3515     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3516     SvCOMPILED_on(sv);
3517 }
3518
3519 /*
3520  * The rest of this file was derived from source code contributed
3521  * by Tom Horsley.
3522  *
3523  * NOTE: this code was derived from Tom Horsley's qsort replacement
3524  * and should not be confused with the original code.
3525  */
3526
3527 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3528
3529    Permission granted to distribute under the same terms as perl which are
3530    (briefly):
3531
3532     This program is free software; you can redistribute it and/or modify
3533     it under the terms of either:
3534
3535         a) the GNU General Public License as published by the Free
3536         Software Foundation; either version 1, or (at your option) any
3537         later version, or
3538
3539         b) the "Artistic License" which comes with this Kit.
3540
3541    Details on the perl license can be found in the perl source code which
3542    may be located via the www.perl.com web page.
3543
3544    This is the most wonderfulest possible qsort I can come up with (and
3545    still be mostly portable) My (limited) tests indicate it consistently
3546    does about 20% fewer calls to compare than does the qsort in the Visual
3547    C++ library, other vendors may vary.
3548
3549    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3550    others I invented myself (or more likely re-invented since they seemed
3551    pretty obvious once I watched the algorithm operate for a while).
3552
3553    Most of this code was written while watching the Marlins sweep the Giants
3554    in the 1997 National League Playoffs - no Braves fans allowed to use this
3555    code (just kidding :-).
3556
3557    I realize that if I wanted to be true to the perl tradition, the only
3558    comment in this file would be something like:
3559
3560    ...they shuffled back towards the rear of the line. 'No, not at the
3561    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3562
3563    However, I really needed to violate that tradition just so I could keep
3564    track of what happens myself, not to mention some poor fool trying to
3565    understand this years from now :-).
3566 */
3567
3568 /* ********************************************************** Configuration */
3569
3570 #ifndef QSORT_ORDER_GUESS
3571 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3572 #endif
3573
3574 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3575    future processing - a good max upper bound is log base 2 of memory size
3576    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3577    safely be smaller than that since the program is taking up some space and
3578    most operating systems only let you grab some subset of contiguous
3579    memory (not to mention that you are normally sorting data larger than
3580    1 byte element size :-).
3581 */
3582 #ifndef QSORT_MAX_STACK
3583 #define QSORT_MAX_STACK 32
3584 #endif
3585
3586 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3587    Anything bigger and we use qsort. If you make this too small, the qsort
3588    will probably break (or become less efficient), because it doesn't expect
3589    the middle element of a partition to be the same as the right or left -
3590    you have been warned).
3591 */
3592 #ifndef QSORT_BREAK_EVEN
3593 #define QSORT_BREAK_EVEN 6
3594 #endif
3595
3596 /* ************************************************************* Data Types */
3597
3598 /* hold left and right index values of a partition waiting to be sorted (the
3599    partition includes both left and right - right is NOT one past the end or
3600    anything like that).
3601 */
3602 struct partition_stack_entry {
3603    int left;
3604    int right;
3605 #ifdef QSORT_ORDER_GUESS
3606    int qsort_break_even;
3607 #endif
3608 };
3609
3610 /* ******************************************************* Shorthand Macros */
3611
3612 /* Note that these macros will be used from inside the qsort function where
3613    we happen to know that the variable 'elt_size' contains the size of an
3614    array element and the variable 'temp' points to enough space to hold a
3615    temp element and the variable 'array' points to the array being sorted
3616    and 'compare' is the pointer to the compare routine.
3617
3618    Also note that there are very many highly architecture specific ways
3619    these might be sped up, but this is simply the most generally portable
3620    code I could think of.
3621 */
3622
3623 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3624 */
3625 #define qsort_cmp(elt1, elt2) \
3626    ((*compare)(aTHXo_ array[elt1], array[elt2]))
3627
3628 #ifdef QSORT_ORDER_GUESS
3629 #define QSORT_NOTICE_SWAP swapped++;
3630 #else
3631 #define QSORT_NOTICE_SWAP
3632 #endif
3633
3634 /* swaps contents of array elements elt1, elt2.
3635 */
3636 #define qsort_swap(elt1, elt2) \
3637    STMT_START { \
3638       QSORT_NOTICE_SWAP \
3639       temp = array[elt1]; \
3640       array[elt1] = array[elt2]; \
3641       array[elt2] = temp; \
3642    } STMT_END
3643
3644 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3645    elt3 and elt3 gets elt1.
3646 */
3647 #define qsort_rotate(elt1, elt2, elt3) \
3648    STMT_START { \
3649       QSORT_NOTICE_SWAP \
3650       temp = array[elt1]; \
3651       array[elt1] = array[elt2]; \
3652       array[elt2] = array[elt3]; \
3653       array[elt3] = temp; \
3654    } STMT_END
3655
3656 /* ************************************************************ Debug stuff */
3657
3658 #ifdef QSORT_DEBUG
3659
3660 static void
3661 break_here()
3662 {
3663    return; /* good place to set a breakpoint */
3664 }
3665
3666 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3667
3668 static void
3669 doqsort_all_asserts(
3670    void * array,
3671    size_t num_elts,
3672    size_t elt_size,
3673    int (*compare)(const void * elt1, const void * elt2),
3674    int pc_left, int pc_right, int u_left, int u_right)
3675 {
3676    int i;
3677
3678    qsort_assert(pc_left <= pc_right);
3679    qsort_assert(u_right < pc_left);
3680    qsort_assert(pc_right < u_left);
3681    for (i = u_right + 1; i < pc_left; ++i) {
3682       qsort_assert(qsort_cmp(i, pc_left) < 0);
3683    }
3684    for (i = pc_left; i < pc_right; ++i) {
3685       qsort_assert(qsort_cmp(i, pc_right) == 0);
3686    }
3687    for (i = pc_right + 1; i < u_left; ++i) {
3688       qsort_assert(qsort_cmp(pc_right, i) < 0);
3689    }
3690 }
3691
3692 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3693    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3694                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3695
3696 #else
3697
3698 #define qsort_assert(t) ((void)0)
3699
3700 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3701
3702 #endif
3703
3704 /* ****************************************************************** qsort */
3705
3706 STATIC void
3707 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3708 {
3709    register SV * temp;
3710
3711    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3712    int next_stack_entry = 0;
3713
3714    int part_left;
3715    int part_right;
3716 #ifdef QSORT_ORDER_GUESS
3717    int qsort_break_even;
3718    int swapped;
3719 #endif
3720
3721    /* Make sure we actually have work to do.
3722    */
3723    if (num_elts <= 1) {
3724       return;
3725    }
3726
3727    /* Setup the initial partition definition and fall into the sorting loop
3728    */
3729    part_left = 0;
3730    part_right = (int)(num_elts - 1);
3731 #ifdef QSORT_ORDER_GUESS
3732    qsort_break_even = QSORT_BREAK_EVEN;
3733 #else
3734 #define qsort_break_even QSORT_BREAK_EVEN
3735 #endif
3736    for ( ; ; ) {
3737       if ((part_right - part_left) >= qsort_break_even) {
3738          /* OK, this is gonna get hairy, so lets try to document all the
3739             concepts and abbreviations and variables and what they keep
3740             track of:
3741
3742             pc: pivot chunk - the set of array elements we accumulate in the
3743                 middle of the partition, all equal in value to the original
3744                 pivot element selected. The pc is defined by:
3745
3746                 pc_left - the leftmost array index of the pc
3747                 pc_right - the rightmost array index of the pc
3748
3749                 we start with pc_left == pc_right and only one element
3750                 in the pivot chunk (but it can grow during the scan).
3751
3752             u:  uncompared elements - the set of elements in the partition
3753                 we have not yet compared to the pivot value. There are two
3754                 uncompared sets during the scan - one to the left of the pc
3755                 and one to the right.
3756
3757                 u_right - the rightmost index of the left side's uncompared set
3758                 u_left - the leftmost index of the right side's uncompared set
3759
3760                 The leftmost index of the left sides's uncompared set
3761                 doesn't need its own variable because it is always defined
3762                 by the leftmost edge of the whole partition (part_left). The
3763                 same goes for the rightmost edge of the right partition
3764                 (part_right).
3765
3766                 We know there are no uncompared elements on the left once we
3767                 get u_right < part_left and no uncompared elements on the
3768                 right once u_left > part_right. When both these conditions
3769                 are met, we have completed the scan of the partition.
3770
3771                 Any elements which are between the pivot chunk and the
3772                 uncompared elements should be less than the pivot value on
3773                 the left side and greater than the pivot value on the right
3774                 side (in fact, the goal of the whole algorithm is to arrange
3775                 for that to be true and make the groups of less-than and
3776                 greater-then elements into new partitions to sort again).
3777
3778             As you marvel at the complexity of the code and wonder why it
3779             has to be so confusing. Consider some of the things this level
3780             of confusion brings:
3781
3782             Once I do a compare, I squeeze every ounce of juice out of it. I
3783             never do compare calls I don't have to do, and I certainly never
3784             do redundant calls.
3785
3786             I also never swap any elements unless I can prove there is a
3787             good reason. Many sort algorithms will swap a known value with
3788             an uncompared value just to get things in the right place (or
3789             avoid complexity :-), but that uncompared value, once it gets
3790             compared, may then have to be swapped again. A lot of the
3791             complexity of this code is due to the fact that it never swaps
3792             anything except compared values, and it only swaps them when the
3793             compare shows they are out of position.
3794          */
3795          int pc_left, pc_right;
3796          int u_right, u_left;
3797
3798          int s;
3799
3800          pc_left = ((part_left + part_right) / 2);
3801          pc_right = pc_left;
3802          u_right = pc_left - 1;
3803          u_left = pc_right + 1;
3804
3805          /* Qsort works best when the pivot value is also the median value
3806             in the partition (unfortunately you can't find the median value
3807             without first sorting :-), so to give the algorithm a helping
3808             hand, we pick 3 elements and sort them and use the median value
3809             of that tiny set as the pivot value.
3810
3811             Some versions of qsort like to use the left middle and right as
3812             the 3 elements to sort so they can insure the ends of the
3813             partition will contain values which will stop the scan in the
3814             compare loop, but when you have to call an arbitrarily complex
3815             routine to do a compare, its really better to just keep track of
3816             array index values to know when you hit the edge of the
3817             partition and avoid the extra compare. An even better reason to
3818             avoid using a compare call is the fact that you can drop off the
3819             edge of the array if someone foolishly provides you with an
3820             unstable compare function that doesn't always provide consistent
3821             results.
3822
3823             So, since it is simpler for us to compare the three adjacent
3824             elements in the middle of the partition, those are the ones we
3825             pick here (conveniently pointed at by u_right, pc_left, and
3826             u_left). The values of the left, center, and right elements
3827             are refered to as l c and r in the following comments.
3828          */
3829
3830 #ifdef QSORT_ORDER_GUESS
3831          swapped = 0;
3832 #endif
3833          s = qsort_cmp(u_right, pc_left);
3834          if (s < 0) {
3835             /* l < c */
3836             s = qsort_cmp(pc_left, u_left);
3837             /* if l < c, c < r - already in order - nothing to do */
3838             if (s == 0) {
3839                /* l < c, c == r - already in order, pc grows */
3840                ++pc_right;
3841                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3842             } else if (s > 0) {
3843                /* l < c, c > r - need to know more */
3844                s = qsort_cmp(u_right, u_left);
3845                if (s < 0) {
3846                   /* l < c, c > r, l < r - swap c & r to get ordered */
3847                   qsort_swap(pc_left, u_left);
3848                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3849                } else if (s == 0) {
3850                   /* l < c, c > r, l == r - swap c&r, grow pc */
3851                   qsort_swap(pc_left, u_left);
3852                   --pc_left;
3853                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3854                } else {
3855                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3856                   qsort_rotate(pc_left, u_right, u_left);
3857                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3858                }
3859             }
3860          } else if (s == 0) {
3861             /* l == c */
3862             s = qsort_cmp(pc_left, u_left);
3863             if (s < 0) {
3864                /* l == c, c < r - already in order, grow pc */
3865                --pc_left;
3866                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3867             } else if (s == 0) {
3868                /* l == c, c == r - already in order, grow pc both ways */
3869                --pc_left;
3870                ++pc_right;
3871                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3872             } else {
3873                /* l == c, c > r - swap l & r, grow pc */
3874                qsort_swap(u_right, u_left);
3875                ++pc_right;
3876                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3877             }
3878          } else {
3879             /* l > c */
3880             s = qsort_cmp(pc_left, u_left);
3881             if (s < 0) {
3882                /* l > c, c < r - need to know more */
3883                s = qsort_cmp(u_right, u_left);
3884                if (s < 0) {
3885                   /* l > c, c < r, l < r - swap l & c to get ordered */
3886                   qsort_swap(u_right, pc_left);
3887                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3888                } else if (s == 0) {
3889                   /* l > c, c < r, l == r - swap l & c, grow pc */
3890                   qsort_swap(u_right, pc_left);
3891                   ++pc_right;
3892                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3893                } else {
3894                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3895                   qsort_rotate(u_right, pc_left, u_left);
3896                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3897                }
3898             } else if (s == 0) {
3899                /* l > c, c == r - swap ends, grow pc */
3900                qsort_swap(u_right, u_left);
3901                --pc_left;
3902                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3903             } else {
3904                /* l > c, c > r - swap ends to get in order */
3905                qsort_swap(u_right, u_left);
3906                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3907             }
3908          }
3909          /* We now know the 3 middle elements have been compared and
3910             arranged in the desired order, so we can shrink the uncompared
3911             sets on both sides
3912          */
3913          --u_right;
3914          ++u_left;
3915          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3916
3917          /* The above massive nested if was the simple part :-). We now have
3918             the middle 3 elements ordered and we need to scan through the
3919             uncompared sets on either side, swapping elements that are on
3920             the wrong side or simply shuffling equal elements around to get
3921             all equal elements into the pivot chunk.
3922          */
3923
3924          for ( ; ; ) {
3925             int still_work_on_left;
3926             int still_work_on_right;
3927
3928             /* Scan the uncompared values on the left. If I find a value
3929                equal to the pivot value, move it over so it is adjacent to
3930                the pivot chunk and expand the pivot chunk. If I find a value
3931                less than the pivot value, then just leave it - its already
3932                on the correct side of the partition. If I find a greater
3933                value, then stop the scan.
3934             */
3935             while (still_work_on_left = (u_right >= part_left)) {
3936                s = qsort_cmp(u_right, pc_left);
3937                if (s < 0) {
3938                   --u_right;
3939                } else if (s == 0) {
3940                   --pc_left;
3941                   if (pc_left != u_right) {
3942                      qsort_swap(u_right, pc_left);
3943                   }
3944                   --u_right;
3945                } else {
3946                   break;
3947                }
3948                qsort_assert(u_right < pc_left);
3949                qsort_assert(pc_left <= pc_right);
3950                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3951                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3952             }
3953
3954             /* Do a mirror image scan of uncompared values on the right
3955             */
3956             while (still_work_on_right = (u_left <= part_right)) {
3957                s = qsort_cmp(pc_right, u_left);
3958                if (s < 0) {
3959                   ++u_left;
3960                } else if (s == 0) {
3961                   ++pc_right;
3962                   if (pc_right != u_left) {
3963                      qsort_swap(pc_right, u_left);
3964                   }
3965                   ++u_left;
3966                } else {
3967                   break;
3968                }
3969                qsort_assert(u_left > pc_right);
3970                qsort_assert(pc_left <= pc_right);
3971                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3972                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3973             }
3974
3975             if (still_work_on_left) {
3976                /* I know I have a value on the left side which needs to be
3977                   on the right side, but I need to know more to decide
3978                   exactly the best thing to do with it.
3979                */
3980                if (still_work_on_right) {
3981                   /* I know I have values on both side which are out of
3982                      position. This is a big win because I kill two birds
3983                      with one swap (so to speak). I can advance the
3984                      uncompared pointers on both sides after swapping both
3985                      of them into the right place.
3986                   */
3987                   qsort_swap(u_right, u_left);
3988                   --u_right;
3989                   ++u_left;
3990                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3991                } else {
3992                   /* I have an out of position value on the left, but the
3993                      right is fully scanned, so I "slide" the pivot chunk
3994                      and any less-than values left one to make room for the
3995                      greater value over on the right. If the out of position
3996                      value is immediately adjacent to the pivot chunk (there
3997                      are no less-than values), I can do that with a swap,
3998                      otherwise, I have to rotate one of the less than values
3999                      into the former position of the out of position value
4000                      and the right end of the pivot chunk into the left end
4001                      (got all that?).
4002                   */
4003                   --pc_left;
4004                   if (pc_left == u_right) {
4005                      qsort_swap(u_right, pc_right);
4006                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4007                   } else {
4008                      qsort_rotate(u_right, pc_left, pc_right);
4009                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4010                   }
4011                   --pc_right;
4012                   --u_right;
4013                }
4014             } else if (still_work_on_right) {
4015                /* Mirror image of complex case above: I have an out of
4016                   position value on the right, but the left is fully
4017                   scanned, so I need to shuffle things around to make room
4018                   for the right value on the left.
4019                */
4020                ++pc_right;
4021                if (pc_right == u_left) {
4022                   qsort_swap(u_left, pc_left);
4023                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4024                } else {
4025                   qsort_rotate(pc_right, pc_left, u_left);
4026                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4027                }
4028                ++pc_left;
4029                ++u_left;
4030             } else {
4031                /* No more scanning required on either side of partition,
4032                   break out of loop and figure out next set of partitions
4033                */
4034                break;
4035             }
4036          }
4037
4038          /* The elements in the pivot chunk are now in the right place. They
4039             will never move or be compared again. All I have to do is decide
4040             what to do with the stuff to the left and right of the pivot
4041             chunk.
4042
4043             Notes on the QSORT_ORDER_GUESS ifdef code:
4044
4045             1. If I just built these partitions without swapping any (or
4046                very many) elements, there is a chance that the elements are
4047                already ordered properly (being properly ordered will
4048                certainly result in no swapping, but the converse can't be
4049                proved :-).
4050
4051             2. A (properly written) insertion sort will run faster on
4052                already ordered data than qsort will.
4053
4054             3. Perhaps there is some way to make a good guess about
4055                switching to an insertion sort earlier than partition size 6
4056                (for instance - we could save the partition size on the stack
4057                and increase the size each time we find we didn't swap, thus
4058                switching to insertion sort earlier for partitions with a
4059                history of not swapping).
4060
4061             4. Naturally, if I just switch right away, it will make
4062                artificial benchmarks with pure ascending (or descending)
4063                data look really good, but is that a good reason in general?
4064                Hard to say...
4065          */
4066
4067 #ifdef QSORT_ORDER_GUESS
4068          if (swapped < 3) {
4069 #if QSORT_ORDER_GUESS == 1
4070             qsort_break_even = (part_right - part_left) + 1;
4071 #endif
4072 #if QSORT_ORDER_GUESS == 2
4073             qsort_break_even *= 2;
4074 #endif
4075 #if QSORT_ORDER_GUESS == 3
4076             int prev_break = qsort_break_even;
4077             qsort_break_even *= qsort_break_even;
4078             if (qsort_break_even < prev_break) {
4079                qsort_break_even = (part_right - part_left) + 1;
4080             }
4081 #endif
4082          } else {
4083             qsort_break_even = QSORT_BREAK_EVEN;
4084          }
4085 #endif
4086
4087          if (part_left < pc_left) {
4088             /* There are elements on the left which need more processing.
4089                Check the right as well before deciding what to do.
4090             */
4091             if (pc_right < part_right) {
4092                /* We have two partitions to be sorted. Stack the biggest one
4093                   and process the smallest one on the next iteration. This
4094                   minimizes the stack height by insuring that any additional
4095                   stack entries must come from the smallest partition which
4096                   (because it is smallest) will have the fewest
4097                   opportunities to generate additional stack entries.
4098                */
4099                if ((part_right - pc_right) > (pc_left - part_left)) {
4100                   /* stack the right partition, process the left */
4101                   partition_stack[next_stack_entry].left = pc_right + 1;
4102                   partition_stack[next_stack_entry].right = part_right;
4103 #ifdef QSORT_ORDER_GUESS
4104                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4105 #endif
4106                   part_right = pc_left - 1;
4107                } else {
4108                   /* stack the left partition, process the right */
4109                   partition_stack[next_stack_entry].left = part_left;
4110                   partition_stack[next_stack_entry].right = pc_left - 1;
4111 #ifdef QSORT_ORDER_GUESS
4112                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4113 #endif
4114                   part_left = pc_right + 1;
4115                }
4116                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4117                ++next_stack_entry;
4118             } else {
4119                /* The elements on the left are the only remaining elements
4120                   that need sorting, arrange for them to be processed as the
4121                   next partition.
4122                */
4123                part_right = pc_left - 1;
4124             }
4125          } else if (pc_right < part_right) {
4126             /* There is only one chunk on the right to be sorted, make it
4127                the new partition and loop back around.
4128             */
4129             part_left = pc_right + 1;
4130          } else {
4131             /* This whole partition wound up in the pivot chunk, so
4132                we need to get a new partition off the stack.
4133             */
4134             if (next_stack_entry == 0) {
4135                /* the stack is empty - we are done */
4136                break;
4137             }
4138             --next_stack_entry;
4139             part_left = partition_stack[next_stack_entry].left;
4140             part_right = partition_stack[next_stack_entry].right;
4141 #ifdef QSORT_ORDER_GUESS
4142             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4143 #endif
4144          }
4145       } else {
4146          /* This partition is too small to fool with qsort complexity, just
4147             do an ordinary insertion sort to minimize overhead.
4148          */
4149          int i;
4150          /* Assume 1st element is in right place already, and start checking
4151             at 2nd element to see where it should be inserted.
4152          */
4153          for (i = part_left + 1; i <= part_right; ++i) {
4154             int j;
4155             /* Scan (backwards - just in case 'i' is already in right place)
4156                through the elements already sorted to see if the ith element
4157                belongs ahead of one of them.
4158             */
4159             for (j = i - 1; j >= part_left; --j) {
4160                if (qsort_cmp(i, j) >= 0) {
4161                   /* i belongs right after j
4162                   */
4163                   break;
4164                }
4165             }
4166             ++j;
4167             if (j != i) {
4168                /* Looks like we really need to move some things
4169                */
4170                int k;
4171                temp = array[i];
4172                for (k = i - 1; k >= j; --k)
4173                   array[k + 1] = array[k];
4174                array[j] = temp;
4175             }
4176          }
4177
4178          /* That partition is now sorted, grab the next one, or get out
4179             of the loop if there aren't any more.
4180          */
4181
4182          if (next_stack_entry == 0) {
4183             /* the stack is empty - we are done */
4184             break;
4185          }
4186          --next_stack_entry;
4187          part_left = partition_stack[next_stack_entry].left;
4188          part_right = partition_stack[next_stack_entry].right;
4189 #ifdef QSORT_ORDER_GUESS
4190          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4191 #endif
4192       }
4193    }
4194
4195    /* Believe it or not, the array is sorted at this point! */
4196 }
4197
4198
4199 #ifdef PERL_OBJECT
4200 #undef this
4201 #define this pPerl
4202 #include "XSUB.h"
4203 #endif
4204
4205
4206 static I32
4207 sortcv(pTHXo_ SV *a, SV *b)
4208 {
4209     dTHR;
4210     I32 oldsaveix = PL_savestack_ix;
4211     I32 oldscopeix = PL_scopestack_ix;
4212     I32 result;
4213     GvSV(PL_firstgv) = a;
4214     GvSV(PL_secondgv) = b;
4215     PL_stack_sp = PL_stack_base;
4216     PL_op = PL_sortcop;
4217     CALLRUNOPS(aTHX);
4218     if (PL_stack_sp != PL_stack_base + 1)
4219         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4220     if (!SvNIOKp(*PL_stack_sp))
4221         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4222     result = SvIV(*PL_stack_sp);
4223     while (PL_scopestack_ix > oldscopeix) {
4224         LEAVE;
4225     }
4226     leave_scope(oldsaveix);
4227     return result;
4228 }
4229
4230 static I32
4231 sortcv_stacked(pTHXo_ SV *a, SV *b)
4232 {
4233     dTHR;
4234     I32 oldsaveix = PL_savestack_ix;
4235     I32 oldscopeix = PL_scopestack_ix;
4236     I32 result;
4237     AV *av;
4238
4239 #ifdef USE_THREADS
4240     av = (AV*)PL_curpad[0];
4241 #else
4242     av = GvAV(PL_defgv);
4243 #endif
4244
4245     if (AvMAX(av) < 1) {
4246         SV** ary = AvALLOC(av);
4247         if (AvARRAY(av) != ary) {
4248             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4249             SvPVX(av) = (char*)ary;
4250         }
4251         if (AvMAX(av) < 1) {
4252             AvMAX(av) = 1;
4253             Renew(ary,2,SV*);
4254             SvPVX(av) = (char*)ary;
4255         }
4256     }
4257     AvFILLp(av) = 1;
4258
4259     AvARRAY(av)[0] = a;
4260     AvARRAY(av)[1] = b;
4261     PL_stack_sp = PL_stack_base;
4262     PL_op = PL_sortcop;
4263     CALLRUNOPS(aTHX);
4264     if (PL_stack_sp != PL_stack_base + 1)
4265         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4266     if (!SvNIOKp(*PL_stack_sp))
4267         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4268     result = SvIV(*PL_stack_sp);
4269     while (PL_scopestack_ix > oldscopeix) {
4270         LEAVE;
4271     }
4272     leave_scope(oldsaveix);
4273     return result;
4274 }
4275
4276 static I32
4277 sortcv_xsub(pTHXo_ SV *a, SV *b)
4278 {
4279     dSP;
4280     I32 oldsaveix = PL_savestack_ix;
4281     I32 oldscopeix = PL_scopestack_ix;
4282     I32 result;
4283     CV *cv=(CV*)PL_sortcop;
4284
4285     SP = PL_stack_base;
4286     PUSHMARK(SP);
4287     EXTEND(SP, 2);
4288     *++SP = a;
4289     *++SP = b;
4290     PUTBACK;
4291     (void)(*CvXSUB(cv))(aTHXo_ cv);
4292     if (PL_stack_sp != PL_stack_base + 1)
4293         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4294     if (!SvNIOKp(*PL_stack_sp))
4295         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4296     result = SvIV(*PL_stack_sp);
4297     while (PL_scopestack_ix > oldscopeix) {
4298         LEAVE;
4299     }
4300     leave_scope(oldsaveix);
4301     return result;
4302 }
4303
4304
4305 static I32
4306 sv_ncmp(pTHXo_ SV *a, SV *b)
4307 {
4308     NV nv1 = SvNV(a);
4309     NV nv2 = SvNV(b);
4310     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4311 }
4312
4313 static I32
4314 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4315 {
4316     IV iv1 = SvIV(a);
4317     IV iv2 = SvIV(b);
4318     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4319 }
4320 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4321           *svp = Nullsv;                                \
4322           if (PL_amagic_generation) { \
4323             if (SvAMAGIC(left)||SvAMAGIC(right))\
4324                 *svp = amagic_call(left, \
4325                                    right, \
4326                                    CAT2(meth,_amg), \
4327                                    0); \
4328           } \
4329         } STMT_END
4330
4331 static I32
4332 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4333 {
4334     SV *tmpsv;
4335     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4336     if (tmpsv) {
4337         NV d;
4338
4339         if (SvIOK(tmpsv)) {
4340             I32 i = SvIVX(tmpsv);
4341             if (i > 0)
4342                return 1;
4343             return i? -1 : 0;
4344         }
4345         d = SvNV(tmpsv);
4346         if (d > 0)
4347            return 1;
4348         return d? -1 : 0;
4349      }
4350      return sv_ncmp(aTHXo_ a, b);
4351 }
4352
4353 static I32
4354 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4355 {
4356     SV *tmpsv;
4357     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4358     if (tmpsv) {
4359         NV d;
4360
4361         if (SvIOK(tmpsv)) {
4362             I32 i = SvIVX(tmpsv);
4363             if (i > 0)
4364                return 1;
4365             return i? -1 : 0;
4366         }
4367         d = SvNV(tmpsv);
4368         if (d > 0)
4369            return 1;
4370         return d? -1 : 0;
4371     }
4372     return sv_i_ncmp(aTHXo_ a, b);
4373 }
4374
4375 static I32
4376 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4377 {
4378     SV *tmpsv;
4379     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4380     if (tmpsv) {
4381         NV d;
4382
4383         if (SvIOK(tmpsv)) {
4384             I32 i = SvIVX(tmpsv);
4385             if (i > 0)
4386                return 1;
4387             return i? -1 : 0;
4388         }
4389         d = SvNV(tmpsv);
4390         if (d > 0)
4391            return 1;
4392         return d? -1 : 0;
4393     }
4394     return sv_cmp(str1, str2);
4395 }
4396
4397 static I32
4398 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4399 {
4400     SV *tmpsv;
4401     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4402     if (tmpsv) {
4403         NV d;
4404
4405         if (SvIOK(tmpsv)) {
4406             I32 i = SvIVX(tmpsv);
4407             if (i > 0)
4408                return 1;
4409             return i? -1 : 0;
4410         }
4411         d = SvNV(tmpsv);
4412         if (d > 0)
4413            return 1;
4414         return d? -1 : 0;
4415     }
4416     return sv_cmp_locale(str1, str2);
4417 }
4418
4419 static I32
4420 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4421 {
4422     SV *datasv = FILTER_DATA(idx);
4423     int filter_has_file = IoLINES(datasv);
4424     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4425     SV *filter_state = (SV *)IoTOP_GV(datasv);
4426     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4427     int len = 0;
4428
4429     /* I was having segfault trouble under Linux 2.2.5 after a
4430        parse error occured.  (Had to hack around it with a test
4431        for PL_error_count == 0.)  Solaris doesn't segfault --
4432        not sure where the trouble is yet.  XXX */
4433
4434     if (filter_has_file) {
4435         len = FILTER_READ(idx+1, buf_sv, maxlen);
4436     }
4437
4438     if (filter_sub && len >= 0) {
4439         djSP;
4440         int count;
4441
4442         ENTER;
4443         SAVE_DEFSV;
4444         SAVETMPS;
4445         EXTEND(SP, 2);
4446
4447         DEFSV = buf_sv;
4448         PUSHMARK(SP);
4449         PUSHs(sv_2mortal(newSViv(maxlen)));
4450         if (filter_state) {
4451             PUSHs(filter_state);
4452         }
4453         PUTBACK;
4454         count = call_sv(filter_sub, G_SCALAR);
4455         SPAGAIN;
4456
4457         if (count > 0) {
4458             SV *out = POPs;
4459             if (SvOK(out)) {
4460                 len = SvIV(out);
4461             }
4462         }
4463
4464         PUTBACK;
4465         FREETMPS;
4466         LEAVE;
4467     }
4468
4469     if (len <= 0) {
4470         IoLINES(datasv) = 0;
4471         if (filter_child_proc) {
4472             SvREFCNT_dec(filter_child_proc);
4473             IoFMT_GV(datasv) = Nullgv;
4474         }
4475         if (filter_state) {
4476             SvREFCNT_dec(filter_state);
4477             IoTOP_GV(datasv) = Nullgv;
4478         }
4479         if (filter_sub) {
4480             SvREFCNT_dec(filter_sub);
4481             IoBOTTOM_GV(datasv) = Nullgv;
4482         }
4483         filter_del(run_user_filter);
4484     }
4485
4486     return len;
4487 }
4488
4489 #ifdef PERL_OBJECT
4490
4491 static I32
4492 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4493 {
4494     return sv_cmp_locale(str1, str2);
4495 }
4496
4497 static I32
4498 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4499 {
4500     return sv_cmp(str1, str2);
4501 }
4502
4503 #endif /* PERL_OBJECT */