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