pp_ctl.c

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