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;
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                 EXTEND_MORTAL(max - i + 1);
1081                 EXTEND(SP, max - i + 1);
1082             }
1083             while (i <= max) {
1084                 sv = sv_2mortal(newSViv(i++));
1085                 PUSHs(sv);
1086             }
1087         }
1088         else {
1089             SV *final = sv_mortalcopy(right);
1090             STRLEN len, n_a;
1091             char *tmps = SvPV(final, len);
1092
1093             sv = sv_mortalcopy(left);
1094             SvPV_force(sv,n_a);
1095             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1096                 XPUSHs(sv);
1097                 if (strEQ(SvPVX(sv),tmps))
1098                     break;
1099                 sv = sv_2mortal(newSVsv(sv));
1100                 sv_inc(sv);
1101             }
1102         }
1103     }
1104     else {
1105         dTOPss;
1106         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1107         sv_inc(targ);
1108         if ((PL_op->op_private & OPpFLIP_LINENUM)
1109           ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1110           : SvTRUE(sv) ) {
1111             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1112             sv_catpv(targ, "E0");
1113         }
1114         SETs(targ);
1115     }
1116
1117     RETURN;
1118 }
1119
1120 /* Control. */
1121
1122 STATIC I32
1123 dopoptolabel(char *label)
1124 {
1125     dTHR;
1126     register I32 i;
1127     register PERL_CONTEXT *cx;
1128
1129     for (i = cxstack_ix; i >= 0; i--) {
1130         cx = &cxstack[i];
1131         switch (CxTYPE(cx)) {
1132         case CXt_SUBST:
1133             if (ckWARN(WARN_UNSAFE))
1134                 warner(WARN_UNSAFE, "Exiting substitution via %s",
1135                         PL_op_name[PL_op->op_type]);
1136             break;
1137         case CXt_SUB:
1138             if (ckWARN(WARN_UNSAFE))
1139                 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1140                         PL_op_name[PL_op->op_type]);
1141             break;
1142         case CXt_EVAL:
1143             if (ckWARN(WARN_UNSAFE))
1144                 warner(WARN_UNSAFE, "Exiting eval via %s",
1145                         PL_op_name[PL_op->op_type]);
1146             break;
1147         case CXt_NULL:
1148             if (ckWARN(WARN_UNSAFE))
1149                 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1150                         PL_op_name[PL_op->op_type]);
1151             return -1;
1152         case CXt_LOOP:
1153             if (!cx->blk_loop.label ||
1154               strNE(label, cx->blk_loop.label) ) {
1155                 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1156                         (long)i, cx->blk_loop.label));
1157                 continue;
1158             }
1159             DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1160             return i;
1161         }
1162     }
1163     return i;
1164 }
1165
1166 I32
1167 dowantarray(void)
1168 {
1169     I32 gimme = block_gimme();
1170     return (gimme == G_VOID) ? G_SCALAR : gimme;
1171 }
1172
1173 I32
1174 block_gimme(void)
1175 {
1176     dTHR;
1177     I32 cxix;
1178
1179     cxix = dopoptosub(cxstack_ix);
1180     if (cxix < 0)
1181         return G_VOID;
1182
1183     switch (cxstack[cxix].blk_gimme) {
1184     case G_VOID:
1185         return G_VOID;
1186     case G_SCALAR:
1187         return G_SCALAR;
1188     case G_ARRAY:
1189         return G_ARRAY;
1190     default:
1191         croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1192         /* NOTREACHED */
1193         return 0;
1194     }
1195 }
1196
1197 STATIC I32
1198 dopoptosub(I32 startingblock)
1199 {
1200     dTHR;
1201     return dopoptosub_at(cxstack, startingblock);
1202 }
1203
1204 STATIC I32
1205 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1206 {
1207     dTHR;
1208     I32 i;
1209     register PERL_CONTEXT *cx;
1210     for (i = startingblock; i >= 0; i--) {
1211         cx = &cxstk[i];
1212         switch (CxTYPE(cx)) {
1213         default:
1214             continue;
1215         case CXt_EVAL:
1216         case CXt_SUB:
1217             DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1218             return i;
1219         }
1220     }
1221     return i;
1222 }
1223
1224 STATIC I32
1225 dopoptoeval(I32 startingblock)
1226 {
1227     dTHR;
1228     I32 i;
1229     register PERL_CONTEXT *cx;
1230     for (i = startingblock; i >= 0; i--) {
1231         cx = &cxstack[i];
1232         switch (CxTYPE(cx)) {
1233         default:
1234             continue;
1235         case CXt_EVAL:
1236             DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1237             return i;
1238         }
1239     }
1240     return i;
1241 }
1242
1243 STATIC I32
1244 dopoptoloop(I32 startingblock)
1245 {
1246     dTHR;
1247     I32 i;
1248     register PERL_CONTEXT *cx;
1249     for (i = startingblock; i >= 0; i--) {
1250         cx = &cxstack[i];
1251         switch (CxTYPE(cx)) {
1252         case CXt_SUBST:
1253             if (ckWARN(WARN_UNSAFE))
1254                 warner(WARN_UNSAFE, "Exiting substitution via %s",
1255                         PL_op_name[PL_op->op_type]);
1256             break;
1257         case CXt_SUB:
1258             if (ckWARN(WARN_UNSAFE))
1259                 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1260                         PL_op_name[PL_op->op_type]);
1261             break;
1262         case CXt_EVAL:
1263             if (ckWARN(WARN_UNSAFE))
1264                 warner(WARN_UNSAFE, "Exiting eval via %s",
1265                         PL_op_name[PL_op->op_type]);
1266             break;
1267         case CXt_NULL:
1268             if (ckWARN(WARN_UNSAFE))
1269                 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1270                         PL_op_name[PL_op->op_type]);
1271             return -1;
1272         case CXt_LOOP:
1273             DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1274             return i;
1275         }
1276     }
1277     return i;
1278 }
1279
1280 void
1281 dounwind(I32 cxix)
1282 {
1283     dTHR;
1284     register PERL_CONTEXT *cx;
1285     SV **newsp;
1286     I32 optype;
1287
1288     while (cxstack_ix > cxix) {
1289         cx = &cxstack[cxstack_ix];
1290         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1291                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1292         /* Note: we don't need to restore the base context info till the end. */
1293         switch (CxTYPE(cx)) {
1294         case CXt_SUBST:
1295             POPSUBST(cx);
1296             continue;  /* not break */
1297         case CXt_SUB:
1298             POPSUB(cx);
1299             break;
1300         case CXt_EVAL:
1301             POPEVAL(cx);
1302             break;
1303         case CXt_LOOP:
1304             POPLOOP(cx);
1305             break;
1306         case CXt_NULL:
1307             break;
1308         }
1309         cxstack_ix--;
1310     }
1311 }
1312
1313 OP *
1314 die_where(char *message)
1315 {
1316     dSP;
1317     STRLEN n_a;
1318     if (PL_in_eval) {
1319         I32 cxix;
1320         register PERL_CONTEXT *cx;
1321         I32 gimme;
1322         SV **newsp;
1323
1324         if (message) {
1325             if (PL_in_eval & 4) {
1326                 SV **svp;
1327                 STRLEN klen = strlen(message);
1328
1329                 svp = hv_fetch(ERRHV, message, klen, TRUE);
1330                 if (svp) {
1331                     if (!SvIOK(*svp)) {
1332                         static char prefix[] = "\t(in cleanup) ";
1333                         SV *err = ERRSV;
1334                         sv_upgrade(*svp, SVt_IV);
1335                         (void)SvIOK_only(*svp);
1336                         if (!SvPOK(err))
1337                             sv_setpv(err,"");
1338                         SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1339                         sv_catpvn(err, prefix, sizeof(prefix)-1);
1340                         sv_catpvn(err, message, klen);
1341                         if (ckWARN(WARN_UNSAFE)) {
1342                             STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
1343                             warner(WARN_UNSAFE, SvPVX(err)+start);
1344                         }
1345                     }
1346                     sv_inc(*svp);
1347                 }
1348             }
1349             else
1350                 sv_setpv(ERRSV, message);
1351         }
1352         else
1353             message = SvPVx(ERRSV, n_a);
1354
1355         while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1356             dounwind(-1);
1357             POPSTACK;
1358         }
1359
1360         if (cxix >= 0) {
1361             I32 optype;
1362
1363             if (cxix < cxstack_ix)
1364                 dounwind(cxix);
1365
1366             POPBLOCK(cx,PL_curpm);
1367             if (CxTYPE(cx) != CXt_EVAL) {
1368                 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1369                 my_exit(1);
1370             }
1371             POPEVAL(cx);
1372
1373             if (gimme == G_SCALAR)
1374                 *++newsp = &PL_sv_undef;
1375             PL_stack_sp = newsp;
1376
1377             LEAVE;
1378
1379             if (optype == OP_REQUIRE) {
1380                 char* msg = SvPVx(ERRSV, n_a);
1381                 DIE("%s", *msg ? msg : "Compilation failed in require");
1382             }
1383             return pop_return();
1384         }
1385     }
1386     if (!message)
1387         message = SvPVx(ERRSV, n_a);
1388     PerlIO_printf(PerlIO_stderr(), "%s",message);
1389     PerlIO_flush(PerlIO_stderr());
1390     my_failure_exit();
1391     /* NOTREACHED */
1392     return 0;
1393 }
1394
1395 PP(pp_xor)
1396 {
1397     djSP; dPOPTOPssrl;
1398     if (SvTRUE(left) != SvTRUE(right))
1399         RETSETYES;
1400     else
1401         RETSETNO;
1402 }
1403
1404 PP(pp_andassign)
1405 {
1406     djSP;
1407     if (!SvTRUE(TOPs))
1408         RETURN;
1409     else
1410         RETURNOP(cLOGOP->op_other);
1411 }
1412
1413 PP(pp_orassign)
1414 {
1415     djSP;
1416     if (SvTRUE(TOPs))
1417         RETURN;
1418     else
1419         RETURNOP(cLOGOP->op_other);
1420 }
1421
1422 PP(pp_caller)
1423 {
1424     djSP;
1425     register I32 cxix = dopoptosub(cxstack_ix);
1426     register PERL_CONTEXT *cx;
1427     register PERL_CONTEXT *ccstack = cxstack;
1428     PERL_SI *top_si = PL_curstackinfo;
1429     I32 dbcxix;
1430     I32 gimme;
1431     HV *hv;
1432     SV *sv;
1433     I32 count = 0;
1434
1435     if (MAXARG)
1436         count = POPi;
1437     EXTEND(SP, 6);
1438     for (;;) {
1439         /* we may be in a higher stacklevel, so dig down deeper */
1440         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1441             top_si = top_si->si_prev;
1442             ccstack = top_si->si_cxstack;
1443             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1444         }
1445         if (cxix < 0) {
1446             if (GIMME != G_ARRAY)
1447                 RETPUSHUNDEF;
1448             RETURN;
1449         }
1450         if (PL_DBsub && cxix >= 0 &&
1451                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1452             count++;
1453         if (!count--)
1454             break;
1455         cxix = dopoptosub_at(ccstack, cxix - 1);
1456     }
1457
1458     cx = &ccstack[cxix];
1459     if (CxTYPE(cx) == CXt_SUB) {
1460         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1461         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1462            field below is defined for any cx. */
1463         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1464             cx = &ccstack[dbcxix];
1465     }
1466
1467     if (GIMME != G_ARRAY) {
1468         hv = cx->blk_oldcop->cop_stash;
1469         if (!hv)
1470             PUSHs(&PL_sv_undef);
1471         else {
1472             dTARGET;
1473             sv_setpv(TARG, HvNAME(hv));
1474             PUSHs(TARG);
1475         }
1476         RETURN;
1477     }
1478
1479     hv = cx->blk_oldcop->cop_stash;
1480     if (!hv)
1481         PUSHs(&PL_sv_undef);
1482     else
1483         PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1484     PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1485     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1486     if (!MAXARG)
1487         RETURN;
1488     if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1489         sv = NEWSV(49, 0);
1490         gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1491         PUSHs(sv_2mortal(sv));
1492         PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1493     }
1494     else {
1495         PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1496         PUSHs(sv_2mortal(newSViv(0)));
1497     }
1498     gimme = (I32)cx->blk_gimme;
1499     if (gimme == G_VOID)
1500         PUSHs(&PL_sv_undef);
1501     else
1502         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1503     if (CxTYPE(cx) == CXt_EVAL) {
1504         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1505             PUSHs(cx->blk_eval.cur_text);
1506             PUSHs(&PL_sv_no);
1507         }
1508         else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1509             /* Require, put the name. */
1510             PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1511             PUSHs(&PL_sv_yes);
1512         }
1513     }
1514     else if (CxTYPE(cx) == CXt_SUB &&
1515             cx->blk_sub.hasargs &&
1516             PL_curcop->cop_stash == PL_debstash)
1517     {
1518         AV *ary = cx->blk_sub.argarray;
1519         int off = AvARRAY(ary) - AvALLOC(ary);
1520
1521         if (!PL_dbargs) {
1522             GV* tmpgv;
1523             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1524                                 SVt_PVAV)));
1525             GvMULTI_on(tmpgv);
1526             AvREAL_off(PL_dbargs);              /* XXX Should be REIFY */
1527         }
1528
1529         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1530             av_extend(PL_dbargs, AvFILLp(ary) + off);
1531         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1532         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1533     }
1534     RETURN;
1535 }
1536
1537 STATIC I32
1538 sortcv(SV *a, SV *b)
1539 {
1540     dTHR;
1541     I32 oldsaveix = PL_savestack_ix;
1542     I32 oldscopeix = PL_scopestack_ix;
1543     I32 result;
1544     GvSV(PL_firstgv) = a;
1545     GvSV(PL_secondgv) = b;
1546     PL_stack_sp = PL_stack_base;
1547     PL_op = PL_sortcop;
1548     CALLRUNOPS();
1549     if (PL_stack_sp != PL_stack_base + 1)
1550         croak("Sort subroutine didn't return single value");
1551     if (!SvNIOKp(*PL_stack_sp))
1552         croak("Sort subroutine didn't return a numeric value");
1553     result = SvIV(*PL_stack_sp);
1554     while (PL_scopestack_ix > oldscopeix) {
1555         LEAVE;
1556     }
1557     leave_scope(oldsaveix);
1558     return result;
1559 }
1560
1561 PP(pp_reset)
1562 {
1563     djSP;
1564     char *tmps;
1565     STRLEN n_a;
1566
1567     if (MAXARG < 1)
1568         tmps = "";
1569     else
1570         tmps = POPpx;
1571     sv_reset(tmps, PL_curcop->cop_stash);
1572     PUSHs(&PL_sv_yes);
1573     RETURN;
1574 }
1575
1576 PP(pp_lineseq)
1577 {
1578     return NORMAL;
1579 }
1580
1581 PP(pp_dbstate)
1582 {
1583     PL_curcop = (COP*)PL_op;
1584     TAINT_NOT;          /* Each statement is presumed innocent */
1585     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1586     FREETMPS;
1587
1588     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1589     {
1590         djSP;
1591         register CV *cv;
1592         register PERL_CONTEXT *cx;
1593         I32 gimme = G_ARRAY;
1594         I32 hasargs;
1595         GV *gv;
1596
1597         gv = PL_DBgv;
1598         cv = GvCV(gv);
1599         if (!cv)
1600             DIE("No DB::DB routine defined");
1601
1602         if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1603             return NORMAL;
1604
1605         ENTER;
1606         SAVETMPS;
1607
1608         SAVEI32(PL_debug);
1609         SAVESTACK_POS();
1610         PL_debug = 0;
1611         hasargs = 0;
1612         SPAGAIN;
1613
1614         push_return(PL_op->op_next);
1615         PUSHBLOCK(cx, CXt_SUB, SP);
1616         PUSHSUB(cx);
1617         CvDEPTH(cv)++;
1618         (void)SvREFCNT_inc(cv);
1619         SAVESPTR(PL_curpad);
1620         PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1621         RETURNOP(CvSTART(cv));
1622     }
1623     else
1624         return NORMAL;
1625 }
1626
1627 PP(pp_scope)
1628 {
1629     return NORMAL;
1630 }
1631
1632 PP(pp_enteriter)
1633 {
1634     djSP; dMARK;
1635     register PERL_CONTEXT *cx;
1636     I32 gimme = GIMME_V;
1637     SV **svp;
1638
1639     ENTER;
1640     SAVETMPS;
1641
1642 #ifdef USE_THREADS
1643     if (PL_op->op_flags & OPf_SPECIAL)
1644         svp = save_threadsv(PL_op->op_targ);    /* per-thread variable */
1645     else
1646 #endif /* USE_THREADS */
1647     if (PL_op->op_targ) {
1648         svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1649         SAVESPTR(*svp);
1650     }
1651     else {
1652         GV *gv = (GV*)POPs;
1653         (void)save_scalar(gv);
1654         svp = &GvSV(gv);                        /* symbol table variable */
1655     }
1656
1657     ENTER;
1658
1659     PUSHBLOCK(cx, CXt_LOOP, SP);
1660     PUSHLOOP(cx, svp, MARK);
1661     if (PL_op->op_flags & OPf_STACKED) {
1662         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1663         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1664             dPOPss;
1665             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1666                 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1667                  if (SvNV(sv) < IV_MIN ||
1668                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1669                      croak("Range iterator outside integer range");
1670                  cx->blk_loop.iterix = SvIV(sv);
1671                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1672             }
1673             else
1674                 cx->blk_loop.iterlval = newSVsv(sv);
1675         }
1676     }
1677     else {
1678         cx->blk_loop.iterary = PL_curstack;
1679         AvFILLp(PL_curstack) = SP - PL_stack_base;
1680         cx->blk_loop.iterix = MARK - PL_stack_base;
1681     }
1682
1683     RETURN;
1684 }
1685
1686 PP(pp_enterloop)
1687 {
1688     djSP;
1689     register PERL_CONTEXT *cx;
1690     I32 gimme = GIMME_V;
1691
1692     ENTER;
1693     SAVETMPS;
1694     ENTER;
1695
1696     PUSHBLOCK(cx, CXt_LOOP, SP);
1697     PUSHLOOP(cx, 0, SP);
1698
1699     RETURN;
1700 }
1701
1702 PP(pp_leaveloop)
1703 {
1704     djSP;
1705     register PERL_CONTEXT *cx;
1706     struct block_loop cxloop;
1707     I32 gimme;
1708     SV **newsp;
1709     PMOP *newpm;
1710     SV **mark;
1711
1712     POPBLOCK(cx,newpm);
1713     mark = newsp;
1714     POPLOOP1(cx);       /* Delay POPLOOP2 until stack values are safe */
1715
1716     TAINT_NOT;
1717     if (gimme == G_VOID)
1718         ; /* do nothing */
1719     else if (gimme == G_SCALAR) {
1720         if (mark < SP)
1721             *++newsp = sv_mortalcopy(*SP);
1722         else
1723             *++newsp = &PL_sv_undef;
1724     }
1725     else {
1726         while (mark < SP) {
1727             *++newsp = sv_mortalcopy(*++mark);
1728             TAINT_NOT;          /* Each item is independent */
1729         }
1730     }
1731     SP = newsp;
1732     PUTBACK;
1733
1734     POPLOOP2();         /* Stack values are safe: release loop vars ... */
1735     PL_curpm = newpm;   /* ... and pop $1 et al */
1736
1737     LEAVE;
1738     LEAVE;
1739
1740     return NORMAL;
1741 }
1742
1743 PP(pp_return)
1744 {
1745     djSP; dMARK;
1746     I32 cxix;
1747     register PERL_CONTEXT *cx;
1748     struct block_sub cxsub;
1749     bool popsub2 = FALSE;
1750     I32 gimme;
1751     SV **newsp;
1752     PMOP *newpm;
1753     I32 optype = 0;
1754
1755     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1756         if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1757             if (cxstack_ix > PL_sortcxix)
1758                 dounwind(PL_sortcxix);
1759             AvARRAY(PL_curstack)[1] = *SP;
1760             PL_stack_sp = PL_stack_base + 1;
1761             return 0;
1762         }
1763     }
1764
1765     cxix = dopoptosub(cxstack_ix);
1766     if (cxix < 0)
1767         DIE("Can't return outside a subroutine");
1768     if (cxix < cxstack_ix)
1769         dounwind(cxix);
1770
1771     POPBLOCK(cx,newpm);
1772     switch (CxTYPE(cx)) {
1773     case CXt_SUB:
1774         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1775         popsub2 = TRUE;
1776         break;
1777     case CXt_EVAL:
1778         POPEVAL(cx);
1779         if (optype == OP_REQUIRE &&
1780             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1781         {
1782             /* Unassume the success we assumed earlier. */
1783             char *name = cx->blk_eval.old_name;
1784             (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1785             DIE("%s did not return a true value", name);
1786         }
1787         break;
1788     default:
1789         DIE("panic: return");
1790     }
1791
1792     TAINT_NOT;
1793     if (gimme == G_SCALAR) {
1794         if (MARK < SP) {
1795             if (popsub2) {
1796                 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1797                     if (SvTEMP(TOPs)) {
1798                         *++newsp = SvREFCNT_inc(*SP);
1799                         FREETMPS;
1800                         sv_2mortal(*newsp);
1801                     } else {
1802                         FREETMPS;
1803                         *++newsp = sv_mortalcopy(*SP);
1804                     }
1805                 } else
1806                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1807             } else
1808                 *++newsp = sv_mortalcopy(*SP);
1809         } else
1810             *++newsp = &PL_sv_undef;
1811     }
1812     else if (gimme == G_ARRAY) {
1813         while (++MARK <= SP) {
1814             *++newsp = (popsub2 && SvTEMP(*MARK))
1815                         ? *MARK : sv_mortalcopy(*MARK);
1816             TAINT_NOT;          /* Each item is independent */
1817         }
1818     }
1819     PL_stack_sp = newsp;
1820
1821     /* Stack values are safe: */
1822     if (popsub2) {
1823         POPSUB2();      /* release CV and @_ ... */
1824     }
1825     PL_curpm = newpm;   /* ... and pop $1 et al */
1826
1827     LEAVE;
1828     return pop_return();
1829 }
1830
1831 PP(pp_last)
1832 {
1833     djSP;
1834     I32 cxix;
1835     register PERL_CONTEXT *cx;
1836     struct block_loop cxloop;
1837     struct block_sub cxsub;
1838     I32 pop2 = 0;
1839     I32 gimme;
1840     I32 optype;
1841     OP *nextop;
1842     SV **newsp;
1843     PMOP *newpm;
1844     SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1845
1846     if (PL_op->op_flags & OPf_SPECIAL) {
1847         cxix = dopoptoloop(cxstack_ix);
1848         if (cxix < 0)
1849             DIE("Can't \"last\" outside a block");
1850     }
1851     else {
1852         cxix = dopoptolabel(cPVOP->op_pv);
1853         if (cxix < 0)
1854             DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1855     }
1856     if (cxix < cxstack_ix)
1857         dounwind(cxix);
1858
1859     POPBLOCK(cx,newpm);
1860     switch (CxTYPE(cx)) {
1861     case CXt_LOOP:
1862         POPLOOP1(cx);   /* Delay POPLOOP2 until stack values are safe */
1863         pop2 = CXt_LOOP;
1864         nextop = cxloop.last_op->op_next;
1865         break;
1866     case CXt_SUB:
1867         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1868         pop2 = CXt_SUB;
1869         nextop = pop_return();
1870         break;
1871     case CXt_EVAL:
1872         POPEVAL(cx);
1873         nextop = pop_return();
1874         break;
1875     default:
1876         DIE("panic: last");
1877     }
1878
1879     TAINT_NOT;
1880     if (gimme == G_SCALAR) {
1881         if (MARK < SP)
1882             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1883                         ? *SP : sv_mortalcopy(*SP);
1884         else
1885             *++newsp = &PL_sv_undef;
1886     }
1887     else if (gimme == G_ARRAY) {
1888         while (++MARK <= SP) {
1889             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1890                         ? *MARK : sv_mortalcopy(*MARK);
1891             TAINT_NOT;          /* Each item is independent */
1892         }
1893     }
1894     SP = newsp;
1895     PUTBACK;
1896
1897     /* Stack values are safe: */
1898     switch (pop2) {
1899     case CXt_LOOP:
1900         POPLOOP2();     /* release loop vars ... */
1901         LEAVE;
1902         break;
1903     case CXt_SUB:
1904         POPSUB2();      /* release CV and @_ ... */
1905         break;
1906     }
1907     PL_curpm = newpm;   /* ... and pop $1 et al */
1908
1909     LEAVE;
1910     return nextop;
1911 }
1912
1913 PP(pp_next)
1914 {
1915     I32 cxix;
1916     register PERL_CONTEXT *cx;
1917     I32 oldsave;
1918
1919     if (PL_op->op_flags & OPf_SPECIAL) {
1920         cxix = dopoptoloop(cxstack_ix);
1921         if (cxix < 0)
1922             DIE("Can't \"next\" outside a block");
1923     }
1924     else {
1925         cxix = dopoptolabel(cPVOP->op_pv);
1926         if (cxix < 0)
1927             DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1928     }
1929     if (cxix < cxstack_ix)
1930         dounwind(cxix);
1931
1932     TOPBLOCK(cx);
1933     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1934     LEAVE_SCOPE(oldsave);
1935     return cx->blk_loop.next_op;
1936 }
1937
1938 PP(pp_redo)
1939 {
1940     I32 cxix;
1941     register PERL_CONTEXT *cx;
1942     I32 oldsave;
1943
1944     if (PL_op->op_flags & OPf_SPECIAL) {
1945         cxix = dopoptoloop(cxstack_ix);
1946         if (cxix < 0)
1947             DIE("Can't \"redo\" outside a block");
1948     }
1949     else {
1950         cxix = dopoptolabel(cPVOP->op_pv);
1951         if (cxix < 0)
1952             DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1953     }
1954     if (cxix < cxstack_ix)
1955         dounwind(cxix);
1956
1957     TOPBLOCK(cx);
1958     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1959     LEAVE_SCOPE(oldsave);
1960     return cx->blk_loop.redo_op;
1961 }
1962
1963 STATIC OP *
1964 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1965 {
1966     OP *kid;
1967     OP **ops = opstack;
1968     static char too_deep[] = "Target of goto is too deeply nested";
1969
1970     if (ops >= oplimit)
1971         croak(too_deep);
1972     if (o->op_type == OP_LEAVE ||
1973         o->op_type == OP_SCOPE ||
1974         o->op_type == OP_LEAVELOOP ||
1975         o->op_type == OP_LEAVETRY)
1976     {
1977         *ops++ = cUNOPo->op_first;
1978         if (ops >= oplimit)
1979             croak(too_deep);
1980     }
1981     *ops = 0;
1982     if (o->op_flags & OPf_KIDS) {
1983         dTHR;
1984         /* First try all the kids at this level, since that's likeliest. */
1985         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1986             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1987                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
1988                 return kid;
1989         }
1990         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1991             if (kid == PL_lastgotoprobe)
1992                 continue;
1993             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1994                 (ops == opstack ||
1995                  (ops[-1]->op_type != OP_NEXTSTATE &&
1996                   ops[-1]->op_type != OP_DBSTATE)))
1997                 *ops++ = kid;
1998             if (o = dofindlabel(kid, label, ops, oplimit))
1999                 return o;
2000         }
2001     }
2002     *ops = 0;
2003     return 0;
2004 }
2005
2006 PP(pp_dump)
2007 {
2008     return pp_goto(ARGS);
2009     /*NOTREACHED*/
2010 }
2011
2012 PP(pp_goto)
2013 {
2014     djSP;
2015     OP *retop = 0;
2016     I32 ix;
2017     register PERL_CONTEXT *cx;
2018 #define GOTO_DEPTH 64
2019     OP *enterops[GOTO_DEPTH];
2020     char *label;
2021     int do_dump = (PL_op->op_type == OP_DUMP);
2022
2023     label = 0;
2024     if (PL_op->op_flags & OPf_STACKED) {
2025         SV *sv = POPs;
2026         STRLEN n_a;
2027
2028         /* This egregious kludge implements goto &subroutine */
2029         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2030             I32 cxix;
2031             register PERL_CONTEXT *cx;
2032             CV* cv = (CV*)SvRV(sv);
2033             SV** mark;
2034             I32 items = 0;
2035             I32 oldsave;
2036             int arg_was_real = 0;
2037
2038         retry:
2039             if (!CvROOT(cv) && !CvXSUB(cv)) {
2040                 GV *gv = CvGV(cv);
2041                 GV *autogv;
2042                 if (gv) {
2043                     SV *tmpstr;
2044                     /* autoloaded stub? */
2045                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2046                         goto retry;
2047                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2048                                           GvNAMELEN(gv), FALSE);
2049                     if (autogv && (cv = GvCV(autogv)))
2050                         goto retry;
2051                     tmpstr = sv_newmortal();
2052                     gv_efullname3(tmpstr, gv, Nullch);
2053                     DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2054                 }
2055                 DIE("Goto undefined subroutine");
2056             }
2057
2058             /* First do some returnish stuff. */
2059             cxix = dopoptosub(cxstack_ix);
2060             if (cxix < 0)
2061                 DIE("Can't goto subroutine outside a subroutine");
2062             if (cxix < cxstack_ix)
2063                 dounwind(cxix);
2064             TOPBLOCK(cx);
2065             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2066                 DIE("Can't goto subroutine from an eval-string");
2067             mark = PL_stack_sp;
2068             if (CxTYPE(cx) == CXt_SUB &&
2069                 cx->blk_sub.hasargs) {   /* put @_ back onto stack */
2070                 AV* av = cx->blk_sub.argarray;
2071
2072                 items = AvFILLp(av) + 1;
2073                 PL_stack_sp++;
2074                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2075                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2076                 PL_stack_sp += items;
2077 #ifndef USE_THREADS
2078                 SvREFCNT_dec(GvAV(PL_defgv));
2079                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2080 #endif /* USE_THREADS */
2081                 if (AvREAL(av)) {
2082                     arg_was_real = 1;
2083                     AvREAL_off(av);     /* so av_clear() won't clobber elts */
2084                 }
2085                 av_clear(av);
2086             }
2087             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2088                 AV* av;
2089                 int i;
2090 #ifdef USE_THREADS
2091                 av = (AV*)PL_curpad[0];
2092 #else
2093                 av = GvAV(PL_defgv);
2094 #endif
2095                 items = AvFILLp(av) + 1;
2096                 PL_stack_sp++;
2097                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2098                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2099                 PL_stack_sp += items;
2100             }
2101             if (CxTYPE(cx) == CXt_SUB &&
2102                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2103                 SvREFCNT_dec(cx->blk_sub.cv);
2104             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2105             LEAVE_SCOPE(oldsave);
2106
2107             /* Now do some callish stuff. */
2108             SAVETMPS;
2109             if (CvXSUB(cv)) {
2110                 if (CvOLDSTYLE(cv)) {
2111                     I32 (*fp3)_((int,int,int));
2112                     while (SP > mark) {
2113                         SP[1] = SP[0];
2114                         SP--;
2115                     }
2116                     fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2117                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2118                                    mark - PL_stack_base + 1,
2119                                    items);
2120                     SP = PL_stack_base + items;
2121                 }
2122                 else {
2123                     SV **newsp;
2124                     I32 gimme;
2125
2126                     PL_stack_sp--;              /* There is no cv arg. */
2127                     /* Push a mark for the start of arglist */
2128                     PUSHMARK(mark);
2129                     (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2130                     /* Pop the current context like a decent sub should */
2131                     POPBLOCK(cx, PL_curpm);
2132                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2133                 }
2134                 LEAVE;
2135                 return pop_return();
2136             }
2137             else {
2138                 AV* padlist = CvPADLIST(cv);
2139                 SV** svp = AvARRAY(padlist);
2140                 if (CxTYPE(cx) == CXt_EVAL) {
2141                     PL_in_eval = cx->blk_eval.old_in_eval;
2142                     PL_eval_root = cx->blk_eval.old_eval_root;
2143                     cx->cx_type = CXt_SUB;
2144                     cx->blk_sub.hasargs = 0;
2145                 }
2146                 cx->blk_sub.cv = cv;
2147                 cx->blk_sub.olddepth = CvDEPTH(cv);
2148                 CvDEPTH(cv)++;
2149                 if (CvDEPTH(cv) < 2)
2150                     (void)SvREFCNT_inc(cv);
2151                 else {  /* save temporaries on recursion? */
2152                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2153                         sub_crush_depth(cv);
2154                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2155                         AV *newpad = newAV();
2156                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2157                         I32 ix = AvFILLp((AV*)svp[1]);
2158                         svp = AvARRAY(svp[0]);
2159                         for ( ;ix > 0; ix--) {
2160                             if (svp[ix] != &PL_sv_undef) {
2161                                 char *name = SvPVX(svp[ix]);
2162                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2163                                     || *name == '&')
2164                                 {
2165                                     /* outer lexical or anon code */
2166                                     av_store(newpad, ix,
2167                                         SvREFCNT_inc(oldpad[ix]) );
2168                                 }
2169                                 else {          /* our own lexical */
2170                                     if (*name == '@')
2171                                         av_store(newpad, ix, sv = (SV*)newAV());
2172                                     else if (*name == '%')
2173                                         av_store(newpad, ix, sv = (SV*)newHV());
2174                                     else
2175                                         av_store(newpad, ix, sv = NEWSV(0,0));
2176                                     SvPADMY_on(sv);
2177                                 }
2178                             }
2179                             else {
2180                                 av_store(newpad, ix, sv = NEWSV(0,0));
2181                                 SvPADTMP_on(sv);
2182                             }
2183                         }
2184                         if (cx->blk_sub.hasargs) {
2185                             AV* av = newAV();
2186                             av_extend(av, 0);
2187                             av_store(newpad, 0, (SV*)av);
2188                             AvFLAGS(av) = AVf_REIFY;
2189                         }
2190                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2191                         AvFILLp(padlist) = CvDEPTH(cv);
2192                         svp = AvARRAY(padlist);
2193                     }
2194                 }
2195 #ifdef USE_THREADS
2196                 if (!cx->blk_sub.hasargs) {
2197                     AV* av = (AV*)PL_curpad[0];
2198
2199                     items = AvFILLp(av) + 1;
2200                     if (items) {
2201                         /* Mark is at the end of the stack. */
2202                         EXTEND(SP, items);
2203                         Copy(AvARRAY(av), SP + 1, items, SV*);
2204                         SP += items;
2205                         PUTBACK ;
2206                     }
2207                 }
2208 #endif /* USE_THREADS */
2209                 SAVESPTR(PL_curpad);
2210                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2211 #ifndef USE_THREADS
2212                 if (cx->blk_sub.hasargs)
2213 #endif /* USE_THREADS */
2214                 {
2215                     AV* av = (AV*)PL_curpad[0];
2216                     SV** ary;
2217
2218 #ifndef USE_THREADS
2219                     cx->blk_sub.savearray = GvAV(PL_defgv);
2220                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2221 #endif /* USE_THREADS */
2222                     cx->blk_sub.argarray = av;
2223                     ++mark;
2224
2225                     if (items >= AvMAX(av) + 1) {
2226                         ary = AvALLOC(av);
2227                         if (AvARRAY(av) != ary) {
2228                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2229                             SvPVX(av) = (char*)ary;
2230                         }
2231                         if (items >= AvMAX(av) + 1) {
2232                             AvMAX(av) = items - 1;
2233                             Renew(ary,items+1,SV*);
2234                             AvALLOC(av) = ary;
2235                             SvPVX(av) = (char*)ary;
2236                         }
2237                     }
2238                     Copy(mark,AvARRAY(av),items,SV*);
2239                     AvFILLp(av) = items - 1;
2240                     /* preserve @_ nature */
2241                     if (arg_was_real) {
2242                         AvREIFY_off(av);
2243                         AvREAL_on(av);
2244                     }
2245                     while (items--) {
2246                         if (*mark)
2247                             SvTEMP_off(*mark);
2248                         mark++;
2249                     }
2250                 }
2251                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2252                     /*
2253                      * We do not care about using sv to call CV;
2254                      * it's for informational purposes only.
2255                      */
2256                     SV *sv = GvSV(PL_DBsub);
2257                     CV *gotocv;
2258
2259                     if (PERLDB_SUB_NN) {
2260                         SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2261                     } else {
2262                         save_item(sv);
2263                         gv_efullname3(sv, CvGV(cv), Nullch);
2264                     }
2265                     if (  PERLDB_GOTO
2266                           && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2267                         PUSHMARK( PL_stack_sp );
2268                         perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2269                         PL_stack_sp--;
2270                     }
2271                 }
2272                 RETURNOP(CvSTART(cv));
2273             }
2274         }
2275         else
2276             label = SvPV(sv,n_a);
2277     }
2278     else if (PL_op->op_flags & OPf_SPECIAL) {
2279         if (! do_dump)
2280             DIE("goto must have label");
2281     }
2282     else
2283         label = cPVOP->op_pv;
2284
2285     if (label && *label) {
2286         OP *gotoprobe = 0;
2287
2288         /* find label */
2289
2290         PL_lastgotoprobe = 0;
2291         *enterops = 0;
2292         for (ix = cxstack_ix; ix >= 0; ix--) {
2293             cx = &cxstack[ix];
2294             switch (CxTYPE(cx)) {
2295             case CXt_EVAL:
2296                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2297                 break;
2298             case CXt_LOOP:
2299                 gotoprobe = cx->blk_oldcop->op_sibling;
2300                 break;
2301             case CXt_SUBST:
2302                 continue;
2303             case CXt_BLOCK:
2304                 if (ix)
2305                     gotoprobe = cx->blk_oldcop->op_sibling;
2306                 else
2307                     gotoprobe = PL_main_root;
2308                 break;
2309             case CXt_SUB:
2310                 if (CvDEPTH(cx->blk_sub.cv)) {
2311                     gotoprobe = CvROOT(cx->blk_sub.cv);
2312                     break;
2313                 }
2314                 /* FALL THROUGH */
2315             case CXt_NULL:
2316                 DIE("Can't \"goto\" outside a block");
2317             default:
2318                 if (ix)
2319                     DIE("panic: goto");
2320                 gotoprobe = PL_main_root;
2321                 break;
2322             }
2323             retop = dofindlabel(gotoprobe, label,
2324                                 enterops, enterops + GOTO_DEPTH);
2325             if (retop)
2326                 break;
2327             PL_lastgotoprobe = gotoprobe;
2328         }
2329         if (!retop)
2330             DIE("Can't find label %s", label);
2331
2332         /* pop unwanted frames */
2333
2334         if (ix < cxstack_ix) {
2335             I32 oldsave;
2336
2337             if (ix < 0)
2338                 ix = 0;
2339             dounwind(ix);
2340             TOPBLOCK(cx);
2341             oldsave = PL_scopestack[PL_scopestack_ix];
2342             LEAVE_SCOPE(oldsave);
2343         }
2344
2345         /* push wanted frames */
2346
2347         if (*enterops && enterops[1]) {
2348             OP *oldop = PL_op;
2349             for (ix = 1; enterops[ix]; ix++) {
2350                 PL_op = enterops[ix];
2351                 /* Eventually we may want to stack the needed arguments
2352                  * for each op.  For now, we punt on the hard ones. */
2353                 if (PL_op->op_type == OP_ENTERITER)
2354                     DIE("Can't \"goto\" into the middle of a foreach loop",
2355                         label);
2356                 (CALLOP->op_ppaddr)(ARGS);
2357             }
2358             PL_op = oldop;
2359         }
2360     }
2361
2362     if (do_dump) {
2363 #ifdef VMS
2364         if (!retop) retop = PL_main_start;
2365 #endif
2366         PL_restartop = retop;
2367         PL_do_undump = TRUE;
2368
2369         my_unexec();
2370
2371         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2372         PL_do_undump = FALSE;
2373     }
2374
2375     RETURNOP(retop);
2376 }
2377
2378 PP(pp_exit)
2379 {
2380     djSP;
2381     I32 anum;
2382
2383     if (MAXARG < 1)
2384         anum = 0;
2385     else {
2386         anum = SvIVx(POPs);
2387 #ifdef VMSISH_EXIT
2388         if (anum == 1 && VMSISH_EXIT)
2389             anum = 0;
2390 #endif
2391     }
2392     my_exit(anum);
2393     PUSHs(&PL_sv_undef);
2394     RETURN;
2395 }
2396
2397 #ifdef NOTYET
2398 PP(pp_nswitch)
2399 {
2400     djSP;
2401     double value = SvNVx(GvSV(cCOP->cop_gv));
2402     register I32 match = I_32(value);
2403
2404     if (value < 0.0) {
2405         if (((double)match) > value)
2406             --match;            /* was fractional--truncate other way */
2407     }
2408     match -= cCOP->uop.scop.scop_offset;
2409     if (match < 0)
2410         match = 0;
2411     else if (match > cCOP->uop.scop.scop_max)
2412         match = cCOP->uop.scop.scop_max;
2413     PL_op = cCOP->uop.scop.scop_next[match];
2414     RETURNOP(PL_op);
2415 }
2416
2417 PP(pp_cswitch)
2418 {
2419     djSP;
2420     register I32 match;
2421
2422     if (PL_multiline)
2423         PL_op = PL_op->op_next;                 /* can't assume anything */
2424     else {
2425         STRLEN n_a;
2426         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2427         match -= cCOP->uop.scop.scop_offset;
2428         if (match < 0)
2429             match = 0;
2430         else if (match > cCOP->uop.scop.scop_max)
2431             match = cCOP->uop.scop.scop_max;
2432         PL_op = cCOP->uop.scop.scop_next[match];
2433     }
2434     RETURNOP(PL_op);
2435 }
2436 #endif
2437
2438 /* Eval. */
2439
2440 STATIC void
2441 save_lines(AV *array, SV *sv)
2442 {
2443     register char *s = SvPVX(sv);
2444     register char *send = SvPVX(sv) + SvCUR(sv);
2445     register char *t;
2446     register I32 line = 1;
2447
2448     while (s && s < send) {
2449         SV *tmpstr = NEWSV(85,0);
2450
2451         sv_upgrade(tmpstr, SVt_PVMG);
2452         t = strchr(s, '\n');
2453         if (t)
2454             t++;
2455         else
2456             t = send;
2457
2458         sv_setpvn(tmpstr, s, t - s);
2459         av_store(array, line++, tmpstr);
2460         s = t;
2461     }
2462 }
2463
2464 STATIC OP *
2465 docatch(OP *o)
2466 {
2467     dTHR;
2468     int ret;
2469     OP *oldop = PL_op;
2470     dJMPENV;
2471
2472     PL_op = o;
2473 #ifdef DEBUGGING
2474     assert(CATCH_GET == TRUE);
2475     DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2476 #endif
2477     JMPENV_PUSH(ret);
2478     switch (ret) {
2479     default:                            /* topmost level handles it */
2480 pass_the_buck:
2481         JMPENV_POP;
2482         PL_op = oldop;
2483         JMPENV_JUMP(ret);
2484         /* NOTREACHED */
2485     case 3:
2486         if (!PL_restartop)
2487             goto pass_the_buck;
2488         PL_op = PL_restartop;
2489         PL_restartop = 0;
2490         /* FALL THROUGH */
2491     case 0:
2492         CALLRUNOPS();
2493         break;
2494     }
2495     JMPENV_POP;
2496     PL_op = oldop;
2497     return Nullop;
2498 }
2499
2500 OP *
2501 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2502 /* sv Text to convert to OP tree. */
2503 /* startop op_free() this to undo. */
2504 /* code Short string id of the caller. */
2505 {
2506     dSP;                                /* Make POPBLOCK work. */
2507     PERL_CONTEXT *cx;
2508     SV **newsp;
2509     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2510     I32 optype;
2511     OP dummy;
2512     OP *oop = PL_op, *rop;
2513     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2514     char *safestr;
2515
2516     ENTER;
2517     lex_start(sv);
2518     SAVETMPS;
2519     /* switch to eval mode */
2520
2521     if (PL_curcop == &PL_compiling) {
2522         SAVESPTR(PL_compiling.cop_stash);
2523         PL_compiling.cop_stash = PL_curstash;
2524     }
2525     SAVESPTR(PL_compiling.cop_filegv);
2526     SAVEI16(PL_compiling.cop_line);
2527     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2528     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2529     PL_compiling.cop_line = 1;
2530     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2531        deleting the eval's FILEGV from the stash before gv_check() runs
2532        (i.e. before run-time proper). To work around the coredump that
2533        ensues, we always turn GvMULTI_on for any globals that were
2534        introduced within evals. See force_ident(). GSAR 96-10-12 */
2535     safestr = savepv(tmpbuf);
2536     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2537     SAVEHINTS();
2538 #ifdef OP_IN_REGISTER
2539     PL_opsave = op;
2540 #else
2541     SAVEPPTR(PL_op);
2542 #endif
2543     PL_hints = 0;
2544
2545     PL_op = &dummy;
2546     PL_op->op_type = OP_ENTEREVAL;
2547     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2548     PUSHBLOCK(cx, CXt_EVAL, SP);
2549     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2550     rop = doeval(G_SCALAR, startop);
2551     POPBLOCK(cx,PL_curpm);
2552     POPEVAL(cx);
2553
2554     (*startop)->op_type = OP_NULL;
2555     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2556     lex_end();
2557     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2558     LEAVE;
2559     if (PL_curcop == &PL_compiling)
2560         PL_compiling.op_private = PL_hints;
2561 #ifdef OP_IN_REGISTER
2562     op = PL_opsave;
2563 #endif
2564     return rop;
2565 }
2566
2567 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2568 STATIC OP *
2569 doeval(int gimme, OP** startop)
2570 {
2571     dSP;
2572     OP *saveop = PL_op;
2573     HV *newstash;
2574     CV *caller;
2575     AV* comppadlist;
2576     I32 i;
2577
2578     PL_in_eval = 1;
2579
2580     PUSHMARK(SP);
2581
2582     /* set up a scratch pad */
2583
2584     SAVEI32(PL_padix);
2585     SAVESPTR(PL_curpad);
2586     SAVESPTR(PL_comppad);
2587     SAVESPTR(PL_comppad_name);
2588     SAVEI32(PL_comppad_name_fill);
2589     SAVEI32(PL_min_intro_pending);
2590     SAVEI32(PL_max_intro_pending);
2591
2592     caller = PL_compcv;
2593     for (i = cxstack_ix - 1; i >= 0; i--) {
2594         PERL_CONTEXT *cx = &cxstack[i];
2595         if (CxTYPE(cx) == CXt_EVAL)
2596             break;
2597         else if (CxTYPE(cx) == CXt_SUB) {
2598             caller = cx->blk_sub.cv;
2599             break;
2600         }
2601     }
2602
2603     SAVESPTR(PL_compcv);
2604     PL_compcv = (CV*)NEWSV(1104,0);
2605     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2606     CvUNIQUE_on(PL_compcv);
2607 #ifdef USE_THREADS
2608     CvOWNER(PL_compcv) = 0;
2609     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2610     MUTEX_INIT(CvMUTEXP(PL_compcv));
2611 #endif /* USE_THREADS */
2612
2613     PL_comppad = newAV();
2614     av_push(PL_comppad, Nullsv);
2615     PL_curpad = AvARRAY(PL_comppad);
2616     PL_comppad_name = newAV();
2617     PL_comppad_name_fill = 0;
2618     PL_min_intro_pending = 0;
2619     PL_padix = 0;
2620 #ifdef USE_THREADS
2621     av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2622     PL_curpad[0] = (SV*)newAV();
2623     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2624 #endif /* USE_THREADS */
2625
2626     comppadlist = newAV();
2627     AvREAL_off(comppadlist);
2628     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2629     av_store(comppadlist, 1, (SV*)PL_comppad);
2630     CvPADLIST(PL_compcv) = comppadlist;
2631
2632     if (!saveop || saveop->op_type != OP_REQUIRE)
2633         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2634
2635     SAVEFREESV(PL_compcv);
2636
2637     /* make sure we compile in the right package */
2638
2639     newstash = PL_curcop->cop_stash;
2640     if (PL_curstash != newstash) {
2641         SAVESPTR(PL_curstash);
2642         PL_curstash = newstash;
2643     }
2644     SAVESPTR(PL_beginav);
2645     PL_beginav = newAV();
2646     SAVEFREESV(PL_beginav);
2647
2648     /* try to compile it */
2649
2650     PL_eval_root = Nullop;
2651     PL_error_count = 0;
2652     PL_curcop = &PL_compiling;
2653     PL_curcop->cop_arybase = 0;
2654     SvREFCNT_dec(PL_rs);
2655     PL_rs = newSVpv("\n", 1);
2656     if (saveop && saveop->op_flags & OPf_SPECIAL)
2657         PL_in_eval |= 4;
2658     else
2659         sv_setpv(ERRSV,"");
2660     if (yyparse() || PL_error_count || !PL_eval_root) {
2661         SV **newsp;
2662         I32 gimme;
2663         PERL_CONTEXT *cx;
2664         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2665         STRLEN n_a;
2666
2667         PL_op = saveop;
2668         if (PL_eval_root) {
2669             op_free(PL_eval_root);
2670             PL_eval_root = Nullop;
2671         }
2672         SP = PL_stack_base + POPMARK;           /* pop original mark */
2673         if (!startop) {
2674             POPBLOCK(cx,PL_curpm);
2675             POPEVAL(cx);
2676             pop_return();
2677         }
2678         lex_end();
2679         LEAVE;
2680         if (optype == OP_REQUIRE) {
2681             char* msg = SvPVx(ERRSV, n_a);
2682             DIE("%s", *msg ? msg : "Compilation failed in require");
2683         } else if (startop) {
2684             char* msg = SvPVx(ERRSV, n_a);
2685
2686             POPBLOCK(cx,PL_curpm);
2687             POPEVAL(cx);
2688             croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2689         }
2690         SvREFCNT_dec(PL_rs);
2691         PL_rs = SvREFCNT_inc(PL_nrs);
2692 #ifdef USE_THREADS
2693         MUTEX_LOCK(&PL_eval_mutex);
2694         PL_eval_owner = 0;
2695         COND_SIGNAL(&PL_eval_cond);
2696         MUTEX_UNLOCK(&PL_eval_mutex);
2697 #endif /* USE_THREADS */
2698         RETPUSHUNDEF;
2699     }
2700     SvREFCNT_dec(PL_rs);
2701     PL_rs = SvREFCNT_inc(PL_nrs);
2702     PL_compiling.cop_line = 0;
2703     if (startop) {
2704         *startop = PL_eval_root;
2705         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2706         CvOUTSIDE(PL_compcv) = Nullcv;
2707     } else
2708         SAVEFREEOP(PL_eval_root);
2709     if (gimme & G_VOID)
2710         scalarvoid(PL_eval_root);
2711     else if (gimme & G_ARRAY)
2712         list(PL_eval_root);
2713     else
2714         scalar(PL_eval_root);
2715
2716     DEBUG_x(dump_eval());
2717
2718     /* Register with debugger: */
2719     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2720         CV *cv = perl_get_cv("DB::postponed", FALSE);
2721         if (cv) {
2722             dSP;
2723             PUSHMARK(SP);
2724             XPUSHs((SV*)PL_compiling.cop_filegv);
2725             PUTBACK;
2726             perl_call_sv((SV*)cv, G_DISCARD);
2727         }
2728     }
2729
2730     /* compiled okay, so do it */
2731
2732     CvDEPTH(PL_compcv) = 1;
2733     SP = PL_stack_base + POPMARK;               /* pop original mark */
2734     PL_op = saveop;                     /* The caller may need it. */
2735 #ifdef USE_THREADS
2736     MUTEX_LOCK(&PL_eval_mutex);
2737     PL_eval_owner = 0;
2738     COND_SIGNAL(&PL_eval_cond);
2739     MUTEX_UNLOCK(&PL_eval_mutex);
2740 #endif /* USE_THREADS */
2741
2742     RETURNOP(PL_eval_start);
2743 }
2744
2745 PP(pp_require)
2746 {
2747     djSP;
2748     register PERL_CONTEXT *cx;
2749     SV *sv;
2750     char *name;
2751     STRLEN len;
2752     char *tryname;
2753     SV *namesv = Nullsv;
2754     SV** svp;
2755     I32 gimme = G_SCALAR;
2756     PerlIO *tryrsfp = 0;
2757     STRLEN n_a;
2758
2759     sv = POPs;
2760     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2761         SET_NUMERIC_STANDARD();
2762         if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2763             DIE("Perl %s required--this is only version %s, stopped",
2764                 SvPV(sv,n_a),PL_patchlevel);
2765         RETPUSHYES;
2766     }
2767     name = SvPV(sv, len);
2768     if (!(name && len > 0 && *name))
2769         DIE("Null filename used");
2770     TAINT_PROPER("require");
2771     if (PL_op->op_type == OP_REQUIRE &&
2772       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2773       *svp != &PL_sv_undef)
2774         RETPUSHYES;
2775
2776     /* prepare to compile file */
2777
2778     if (*name == '/' ||
2779         (*name == '.' &&
2780             (name[1] == '/' ||
2781              (name[1] == '.' && name[2] == '/')))
2782 #ifdef DOSISH
2783       || (name[0] && name[1] == ':')
2784 #endif
2785 #ifdef WIN32
2786       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2787 #endif
2788 #ifdef VMS
2789         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2790             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2791 #endif
2792     )
2793     {
2794         tryname = name;
2795         tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2796     }
2797     else {
2798         AV *ar = GvAVn(PL_incgv);
2799         I32 i;
2800 #ifdef VMS
2801         char *unixname;
2802         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2803 #endif
2804         {
2805             namesv = NEWSV(806, 0);
2806             for (i = 0; i <= AvFILL(ar); i++) {
2807                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2808 #ifdef VMS
2809                 char *unixdir;
2810                 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2811                     continue;
2812                 sv_setpv(namesv, unixdir);
2813                 sv_catpv(namesv, unixname);
2814 #else
2815                 sv_setpvf(namesv, "%s/%s", dir, name);
2816 #endif
2817                 TAINT_PROPER("require");
2818                 tryname = SvPVX(namesv);
2819                 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2820                 if (tryrsfp) {
2821                     if (tryname[0] == '.' && tryname[1] == '/')
2822                         tryname += 2;
2823                     break;
2824                 }
2825             }
2826         }
2827     }
2828     SAVESPTR(PL_compiling.cop_filegv);
2829     PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2830     SvREFCNT_dec(namesv);
2831     if (!tryrsfp) {
2832         if (PL_op->op_type == OP_REQUIRE) {
2833             SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2834             SV *dirmsgsv = NEWSV(0, 0);
2835             AV *ar = GvAVn(PL_incgv);
2836             I32 i;
2837             if (instr(SvPVX(msg), ".h "))
2838                 sv_catpv(msg, " (change .h to .ph maybe?)");
2839             if (instr(SvPVX(msg), ".ph "))
2840                 sv_catpv(msg, " (did you run h2ph?)");
2841             sv_catpv(msg, " (@INC contains:");
2842             for (i = 0; i <= AvFILL(ar); i++) {
2843                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2844                 sv_setpvf(dirmsgsv, " %s", dir);
2845                 sv_catsv(msg, dirmsgsv);
2846             }
2847             sv_catpvn(msg, ")", 1);
2848             SvREFCNT_dec(dirmsgsv);
2849             DIE("%_", msg);
2850         }
2851
2852         RETPUSHUNDEF;
2853     }
2854     else
2855         SETERRNO(0, SS$_NORMAL);
2856
2857     /* Assume success here to prevent recursive requirement. */
2858     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2859         newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2860
2861     ENTER;
2862     SAVETMPS;
2863     lex_start(sv_2mortal(newSVpv("",0)));
2864     SAVEGENERICSV(PL_rsfp_filters);
2865     PL_rsfp_filters = Nullav;
2866
2867     PL_rsfp = tryrsfp;
2868     name = savepv(name);
2869     SAVEFREEPV(name);
2870     SAVEHINTS();
2871     PL_hints = 0;
2872     SAVEPPTR(PL_compiling.cop_warnings);
2873     PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2874                                                              : WARN_NONE);
2875
2876     /* switch to eval mode */
2877
2878     push_return(PL_op->op_next);
2879     PUSHBLOCK(cx, CXt_EVAL, SP);
2880     PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2881
2882     SAVEI16(PL_compiling.cop_line);
2883     PL_compiling.cop_line = 0;
2884
2885     PUTBACK;
2886 #ifdef USE_THREADS
2887     MUTEX_LOCK(&PL_eval_mutex);
2888     if (PL_eval_owner && PL_eval_owner != thr)
2889         while (PL_eval_owner)
2890             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2891     PL_eval_owner = thr;
2892     MUTEX_UNLOCK(&PL_eval_mutex);
2893 #endif /* USE_THREADS */
2894     return DOCATCH(doeval(G_SCALAR, NULL));
2895 }
2896
2897 PP(pp_dofile)
2898 {
2899     return pp_require(ARGS);
2900 }
2901
2902 PP(pp_entereval)
2903 {
2904     djSP;
2905     register PERL_CONTEXT *cx;
2906     dPOPss;
2907     I32 gimme = GIMME_V, was = PL_sub_generation;
2908     char tmpbuf[TYPE_DIGITS(long) + 12];
2909     char *safestr;
2910     STRLEN len;
2911     OP *ret;
2912
2913     if (!SvPV(sv,len) || !len)
2914         RETPUSHUNDEF;
2915     TAINT_PROPER("eval");
2916
2917     ENTER;
2918     lex_start(sv);
2919     SAVETMPS;
2920
2921     /* switch to eval mode */
2922
2923     SAVESPTR(PL_compiling.cop_filegv);
2924     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2925     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2926     PL_compiling.cop_line = 1;
2927     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2928        deleting the eval's FILEGV from the stash before gv_check() runs
2929        (i.e. before run-time proper). To work around the coredump that
2930        ensues, we always turn GvMULTI_on for any globals that were
2931        introduced within evals. See force_ident(). GSAR 96-10-12 */
2932     safestr = savepv(tmpbuf);
2933     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2934     SAVEHINTS();
2935     PL_hints = PL_op->op_targ;
2936     SAVEPPTR(PL_compiling.cop_warnings);
2937     if (PL_compiling.cop_warnings != WARN_ALL
2938         && PL_compiling.cop_warnings != WARN_NONE){
2939         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2940         SAVEFREESV(PL_compiling.cop_warnings) ;
2941     }
2942
2943     push_return(PL_op->op_next);
2944     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2945     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2946
2947     /* prepare to compile string */
2948
2949     if (PERLDB_LINE && PL_curstash != PL_debstash)
2950         save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2951     PUTBACK;
2952 #ifdef USE_THREADS
2953     MUTEX_LOCK(&PL_eval_mutex);
2954     if (PL_eval_owner && PL_eval_owner != thr)
2955         while (PL_eval_owner)
2956             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2957     PL_eval_owner = thr;
2958     MUTEX_UNLOCK(&PL_eval_mutex);
2959 #endif /* USE_THREADS */
2960     ret = doeval(gimme, NULL);
2961     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2962         && ret != PL_op->op_next) {     /* Successive compilation. */
2963         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
2964     }
2965     return DOCATCH(ret);
2966 }
2967
2968 PP(pp_leaveeval)
2969 {
2970     djSP;
2971     register SV **mark;
2972     SV **newsp;
2973     PMOP *newpm;
2974     I32 gimme;
2975     register PERL_CONTEXT *cx;
2976     OP *retop;
2977     U8 save_flags = PL_op -> op_flags;
2978     I32 optype;
2979
2980     POPBLOCK(cx,newpm);
2981     POPEVAL(cx);
2982     retop = pop_return();
2983
2984     TAINT_NOT;
2985     if (gimme == G_VOID)
2986         MARK = newsp;
2987     else if (gimme == G_SCALAR) {
2988         MARK = newsp + 1;
2989         if (MARK <= SP) {
2990             if (SvFLAGS(TOPs) & SVs_TEMP)
2991                 *MARK = TOPs;
2992             else
2993                 *MARK = sv_mortalcopy(TOPs);
2994         }
2995         else {
2996             MEXTEND(mark,0);
2997             *MARK = &PL_sv_undef;
2998         }
2999     }
3000     else {
3001         /* in case LEAVE wipes old return values */
3002         for (mark = newsp + 1; mark <= SP; mark++) {
3003             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3004                 *mark = sv_mortalcopy(*mark);
3005                 TAINT_NOT;      /* Each item is independent */
3006             }
3007         }
3008     }
3009     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3010
3011     /*
3012      * Closures mentioned at top level of eval cannot be referenced
3013      * again, and their presence indirectly causes a memory leak.
3014      * (Note that the fact that compcv and friends are still set here
3015      * is, AFAIK, an accident.)  --Chip
3016      */
3017     if (AvFILLp(PL_comppad_name) >= 0) {
3018         SV **svp = AvARRAY(PL_comppad_name);
3019         I32 ix;
3020         for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3021             SV *sv = svp[ix];
3022             if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3023                 SvREFCNT_dec(sv);
3024                 svp[ix] = &PL_sv_undef;
3025
3026                 sv = PL_curpad[ix];
3027                 if (CvCLONE(sv)) {
3028                     SvREFCNT_dec(CvOUTSIDE(sv));
3029                     CvOUTSIDE(sv) = Nullcv;
3030                 }
3031                 else {
3032                     SvREFCNT_dec(sv);
3033                     sv = NEWSV(0,0);
3034                     SvPADTMP_on(sv);
3035                     PL_curpad[ix] = sv;
3036                 }
3037             }
3038         }
3039     }
3040
3041 #ifdef DEBUGGING
3042     assert(CvDEPTH(PL_compcv) == 1);
3043 #endif
3044     CvDEPTH(PL_compcv) = 0;
3045     lex_end();
3046
3047     if (optype == OP_REQUIRE &&
3048         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3049     {
3050         /* Unassume the success we assumed earlier. */
3051         char *name = cx->blk_eval.old_name;
3052         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3053         retop = die("%s did not return a true value", name);
3054         /* die_where() did LEAVE, or we won't be here */
3055     }
3056     else {
3057         LEAVE;
3058         if (!(save_flags & OPf_SPECIAL))
3059             sv_setpv(ERRSV,"");
3060     }
3061
3062     RETURNOP(retop);
3063 }
3064
3065 PP(pp_entertry)
3066 {
3067     djSP;
3068     register PERL_CONTEXT *cx;
3069     I32 gimme = GIMME_V;
3070
3071     ENTER;
3072     SAVETMPS;
3073
3074     push_return(cLOGOP->op_other->op_next);
3075     PUSHBLOCK(cx, CXt_EVAL, SP);
3076     PUSHEVAL(cx, 0, 0);
3077     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3078
3079     PL_in_eval = 1;
3080     sv_setpv(ERRSV,"");
3081     PUTBACK;
3082     return DOCATCH(PL_op->op_next);
3083 }
3084
3085 PP(pp_leavetry)
3086 {
3087     djSP;
3088     register SV **mark;
3089     SV **newsp;
3090     PMOP *newpm;
3091     I32 gimme;
3092     register PERL_CONTEXT *cx;
3093     I32 optype;
3094
3095     POPBLOCK(cx,newpm);
3096     POPEVAL(cx);
3097     pop_return();
3098
3099     TAINT_NOT;
3100     if (gimme == G_VOID)
3101         SP = newsp;
3102     else if (gimme == G_SCALAR) {
3103         MARK = newsp + 1;
3104         if (MARK <= SP) {
3105             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3106                 *MARK = TOPs;
3107             else
3108                 *MARK = sv_mortalcopy(TOPs);
3109         }
3110         else {
3111             MEXTEND(mark,0);
3112             *MARK = &PL_sv_undef;
3113         }
3114         SP = MARK;
3115     }
3116     else {
3117         /* in case LEAVE wipes old return values */
3118         for (mark = newsp + 1; mark <= SP; mark++) {
3119             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3120                 *mark = sv_mortalcopy(*mark);
3121                 TAINT_NOT;      /* Each item is independent */
3122             }
3123         }
3124     }
3125     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3126
3127     LEAVE;
3128     sv_setpv(ERRSV,"");
3129     RETURN;
3130 }
3131
3132 STATIC void
3133 doparseform(SV *sv)
3134 {
3135     STRLEN len;
3136     register char *s = SvPV_force(sv, len);
3137     register char *send = s + len;
3138     register char *base;
3139     register I32 skipspaces = 0;
3140     bool noblank;
3141     bool repeat;
3142     bool postspace = FALSE;
3143     U16 *fops;
3144     register U16 *fpc;
3145     U16 *linepc;
3146     register I32 arg;
3147     bool ischop;
3148
3149     if (len == 0)
3150         croak("Null picture in formline");
3151
3152     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3153     fpc = fops;
3154
3155     if (s < send) {
3156         linepc = fpc;
3157         *fpc++ = FF_LINEMARK;
3158         noblank = repeat = FALSE;
3159         base = s;
3160     }
3161
3162     while (s <= send) {
3163         switch (*s++) {
3164         default:
3165             skipspaces = 0;
3166             continue;
3167
3168         case '~':
3169             if (*s == '~') {
3170                 repeat = TRUE;
3171                 *s = ' ';
3172             }
3173             noblank = TRUE;
3174             s[-1] = ' ';
3175             /* FALL THROUGH */
3176         case ' ': case '\t':
3177             skipspaces++;
3178             continue;
3179
3180         case '\n': case 0:
3181             arg = s - base;
3182             skipspaces++;
3183             arg -= skipspaces;
3184             if (arg) {
3185                 if (postspace)
3186                     *fpc++ = FF_SPACE;
3187                 *fpc++ = FF_LITERAL;
3188                 *fpc++ = arg;
3189             }
3190             postspace = FALSE;
3191             if (s <= send)
3192                 skipspaces--;
3193             if (skipspaces) {
3194                 *fpc++ = FF_SKIP;
3195                 *fpc++ = skipspaces;
3196             }
3197             skipspaces = 0;
3198             if (s <= send)
3199                 *fpc++ = FF_NEWLINE;
3200             if (noblank) {
3201                 *fpc++ = FF_BLANK;
3202                 if (repeat)
3203                     arg = fpc - linepc + 1;
3204                 else
3205                     arg = 0;
3206                 *fpc++ = arg;
3207             }
3208             if (s < send) {
3209                 linepc = fpc;
3210                 *fpc++ = FF_LINEMARK;
3211                 noblank = repeat = FALSE;
3212                 base = s;
3213             }
3214             else
3215                 s++;
3216             continue;
3217
3218         case '@':
3219         case '^':
3220             ischop = s[-1] == '^';
3221
3222             if (postspace) {
3223                 *fpc++ = FF_SPACE;
3224                 postspace = FALSE;
3225             }
3226             arg = (s - base) - 1;
3227             if (arg) {
3228                 *fpc++ = FF_LITERAL;
3229                 *fpc++ = arg;
3230             }
3231
3232             base = s - 1;
3233             *fpc++ = FF_FETCH;
3234             if (*s == '*') {
3235                 s++;
3236                 *fpc++ = 0;
3237                 *fpc++ = FF_LINEGLOB;
3238             }
3239             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3240                 arg = ischop ? 512 : 0;
3241                 base = s - 1;
3242                 while (*s == '#')
3243                     s++;
3244                 if (*s == '.') {
3245                     char *f;
3246                     s++;
3247                     f = s;
3248                     while (*s == '#')
3249                         s++;
3250                     arg |= 256 + (s - f);
3251                 }
3252                 *fpc++ = s - base;              /* fieldsize for FETCH */
3253                 *fpc++ = FF_DECIMAL;
3254                 *fpc++ = arg;
3255             }
3256             else {
3257                 I32 prespace = 0;
3258                 bool ismore = FALSE;
3259
3260                 if (*s == '>') {
3261                     while (*++s == '>') ;
3262                     prespace = FF_SPACE;
3263                 }
3264                 else if (*s == '|') {
3265                     while (*++s == '|') ;
3266                     prespace = FF_HALFSPACE;
3267                     postspace = TRUE;
3268                 }
3269                 else {
3270                     if (*s == '<')
3271                         while (*++s == '<') ;
3272                     postspace = TRUE;
3273                 }
3274                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3275                     s += 3;
3276                     ismore = TRUE;
3277                 }
3278                 *fpc++ = s - base;              /* fieldsize for FETCH */
3279
3280                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3281
3282                 if (prespace)
3283                     *fpc++ = prespace;
3284                 *fpc++ = FF_ITEM;
3285                 if (ismore)
3286                     *fpc++ = FF_MORE;
3287                 if (ischop)
3288                     *fpc++ = FF_CHOP;
3289             }
3290             base = s;
3291             skipspaces = 0;
3292             continue;
3293         }
3294     }
3295     *fpc++ = FF_END;
3296
3297     arg = fpc - fops;
3298     { /* need to jump to the next word */
3299         int z;
3300         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3301         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3302         s = SvPVX(sv) + SvCUR(sv) + z;
3303     }
3304     Copy(fops, s, arg, U16);
3305     Safefree(fops);
3306     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3307     SvCOMPILED_on(sv);
3308 }
3309
3310 /*
3311  * The rest of this file was derived from source code contributed
3312  * by Tom Horsley.
3313  *
3314  * NOTE: this code was derived from Tom Horsley's qsort replacement
3315  * and should not be confused with the original code.
3316  */
3317
3318 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3319
3320    Permission granted to distribute under the same terms as perl which are
3321    (briefly):
3322
3323     This program is free software; you can redistribute it and/or modify
3324     it under the terms of either:
3325
3326         a) the GNU General Public License as published by the Free
3327         Software Foundation; either version 1, or (at your option) any
3328         later version, or
3329
3330         b) the "Artistic License" which comes with this Kit.
3331
3332    Details on the perl license can be found in the perl source code which
3333    may be located via the www.perl.com web page.
3334
3335    This is the most wonderfulest possible qsort I can come up with (and
3336    still be mostly portable) My (limited) tests indicate it consistently
3337    does about 20% fewer calls to compare than does the qsort in the Visual
3338    C++ library, other vendors may vary.
3339
3340    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3341    others I invented myself (or more likely re-invented since they seemed
3342    pretty obvious once I watched the algorithm operate for a while).
3343
3344    Most of this code was written while watching the Marlins sweep the Giants
3345    in the 1997 National League Playoffs - no Braves fans allowed to use this
3346    code (just kidding :-).
3347
3348    I realize that if I wanted to be true to the perl tradition, the only
3349    comment in this file would be something like:
3350
3351    ...they shuffled back towards the rear of the line. 'No, not at the
3352    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3353
3354    However, I really needed to violate that tradition just so I could keep
3355    track of what happens myself, not to mention some poor fool trying to
3356    understand this years from now :-).
3357 */
3358
3359 /* ********************************************************** Configuration */
3360
3361 #ifndef QSORT_ORDER_GUESS
3362 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3363 #endif
3364
3365 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3366    future processing - a good max upper bound is log base 2 of memory size
3367    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3368    safely be smaller than that since the program is taking up some space and
3369    most operating systems only let you grab some subset of contiguous
3370    memory (not to mention that you are normally sorting data larger than
3371    1 byte element size :-).
3372 */
3373 #ifndef QSORT_MAX_STACK
3374 #define QSORT_MAX_STACK 32
3375 #endif
3376
3377 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3378    Anything bigger and we use qsort. If you make this too small, the qsort
3379    will probably break (or become less efficient), because it doesn't expect
3380    the middle element of a partition to be the same as the right or left -
3381    you have been warned).
3382 */
3383 #ifndef QSORT_BREAK_EVEN
3384 #define QSORT_BREAK_EVEN 6
3385 #endif
3386
3387 /* ************************************************************* Data Types */
3388
3389 /* hold left and right index values of a partition waiting to be sorted (the
3390    partition includes both left and right - right is NOT one past the end or
3391    anything like that).
3392 */
3393 struct partition_stack_entry {
3394    int left;
3395    int right;
3396 #ifdef QSORT_ORDER_GUESS
3397    int qsort_break_even;
3398 #endif
3399 };
3400
3401 /* ******************************************************* Shorthand Macros */
3402
3403 /* Note that these macros will be used from inside the qsort function where
3404    we happen to know that the variable 'elt_size' contains the size of an
3405    array element and the variable 'temp' points to enough space to hold a
3406    temp element and the variable 'array' points to the array being sorted
3407    and 'compare' is the pointer to the compare routine.
3408
3409    Also note that there are very many highly architecture specific ways
3410    these might be sped up, but this is simply the most generally portable
3411    code I could think of.
3412 */
3413
3414 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3415 */
3416 #ifdef PERL_OBJECT
3417 #define qsort_cmp(elt1, elt2) \
3418    ((this->*compare)(array[elt1], array[elt2]))
3419 #else
3420 #define qsort_cmp(elt1, elt2) \
3421    ((*compare)(array[elt1], array[elt2]))
3422 #endif
3423
3424 #ifdef QSORT_ORDER_GUESS
3425 #define QSORT_NOTICE_SWAP swapped++;
3426 #else
3427 #define QSORT_NOTICE_SWAP
3428 #endif
3429
3430 /* swaps contents of array elements elt1, elt2.
3431 */
3432 #define qsort_swap(elt1, elt2) \
3433    STMT_START { \
3434       QSORT_NOTICE_SWAP \
3435       temp = array[elt1]; \
3436       array[elt1] = array[elt2]; \
3437       array[elt2] = temp; \
3438    } STMT_END
3439
3440 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3441    elt3 and elt3 gets elt1.
3442 */
3443 #define qsort_rotate(elt1, elt2, elt3) \
3444    STMT_START { \
3445       QSORT_NOTICE_SWAP \
3446       temp = array[elt1]; \
3447       array[elt1] = array[elt2]; \
3448       array[elt2] = array[elt3]; \
3449       array[elt3] = temp; \
3450    } STMT_END
3451
3452 /* ************************************************************ Debug stuff */
3453
3454 #ifdef QSORT_DEBUG
3455
3456 static void
3457 break_here()
3458 {
3459    return; /* good place to set a breakpoint */
3460 }
3461
3462 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3463
3464 static void
3465 doqsort_all_asserts(
3466    void * array,
3467    size_t num_elts,
3468    size_t elt_size,
3469    int (*compare)(const void * elt1, const void * elt2),
3470    int pc_left, int pc_right, int u_left, int u_right)
3471 {
3472    int i;
3473
3474    qsort_assert(pc_left <= pc_right);
3475    qsort_assert(u_right < pc_left);
3476    qsort_assert(pc_right < u_left);
3477    for (i = u_right + 1; i < pc_left; ++i) {
3478       qsort_assert(qsort_cmp(i, pc_left) < 0);
3479    }
3480    for (i = pc_left; i < pc_right; ++i) {
3481       qsort_assert(qsort_cmp(i, pc_right) == 0);
3482    }
3483    for (i = pc_right + 1; i < u_left; ++i) {
3484       qsort_assert(qsort_cmp(pc_right, i) < 0);
3485    }
3486 }
3487
3488 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3489    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3490                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3491
3492 #else
3493
3494 #define qsort_assert(t) ((void)0)
3495
3496 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3497
3498 #endif
3499
3500 /* ****************************************************************** qsort */
3501
3502 STATIC void
3503 #ifdef PERL_OBJECT
3504 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3505 #else
3506 qsortsv(
3507    SV ** array,
3508    size_t num_elts,
3509    I32 (*compare)(SV *a, SV *b))
3510 #endif
3511 {
3512    register SV * temp;
3513
3514    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3515    int next_stack_entry = 0;
3516
3517    int part_left;
3518    int part_right;
3519 #ifdef QSORT_ORDER_GUESS
3520    int qsort_break_even;
3521    int swapped;
3522 #endif
3523
3524    /* Make sure we actually have work to do.
3525    */
3526    if (num_elts <= 1) {
3527       return;
3528    }
3529
3530    /* Setup the initial partition definition and fall into the sorting loop
3531    */
3532    part_left = 0;
3533    part_right = (int)(num_elts - 1);
3534 #ifdef QSORT_ORDER_GUESS
3535    qsort_break_even = QSORT_BREAK_EVEN;
3536 #else
3537 #define qsort_break_even QSORT_BREAK_EVEN
3538 #endif
3539    for ( ; ; ) {
3540       if ((part_right - part_left) >= qsort_break_even) {
3541          /* OK, this is gonna get hairy, so lets try to document all the
3542             concepts and abbreviations and variables and what they keep
3543             track of:
3544
3545             pc: pivot chunk - the set of array elements we accumulate in the
3546                 middle of the partition, all equal in value to the original
3547                 pivot element selected. The pc is defined by:
3548
3549                 pc_left - the leftmost array index of the pc
3550                 pc_right - the rightmost array index of the pc
3551
3552                 we start with pc_left == pc_right and only one element
3553                 in the pivot chunk (but it can grow during the scan).
3554
3555             u:  uncompared elements - the set of elements in the partition
3556                 we have not yet compared to the pivot value. There are two
3557                 uncompared sets during the scan - one to the left of the pc
3558                 and one to the right.
3559
3560                 u_right - the rightmost index of the left side's uncompared set
3561                 u_left - the leftmost index of the right side's uncompared set
3562
3563                 The leftmost index of the left sides's uncompared set
3564                 doesn't need its own variable because it is always defined
3565                 by the leftmost edge of the whole partition (part_left). The
3566                 same goes for the rightmost edge of the right partition
3567                 (part_right).
3568
3569                 We know there are no uncompared elements on the left once we
3570                 get u_right < part_left and no uncompared elements on the
3571                 right once u_left > part_right. When both these conditions
3572                 are met, we have completed the scan of the partition.
3573
3574                 Any elements which are between the pivot chunk and the
3575                 uncompared elements should be less than the pivot value on
3576                 the left side and greater than the pivot value on the right
3577                 side (in fact, the goal of the whole algorithm is to arrange
3578                 for that to be true and make the groups of less-than and
3579                 greater-then elements into new partitions to sort again).
3580
3581             As you marvel at the complexity of the code and wonder why it
3582             has to be so confusing. Consider some of the things this level
3583             of confusion brings:
3584
3585             Once I do a compare, I squeeze every ounce of juice out of it. I
3586             never do compare calls I don't have to do, and I certainly never
3587             do redundant calls.
3588
3589             I also never swap any elements unless I can prove there is a
3590             good reason. Many sort algorithms will swap a known value with
3591             an uncompared value just to get things in the right place (or
3592             avoid complexity :-), but that uncompared value, once it gets
3593             compared, may then have to be swapped again. A lot of the
3594             complexity of this code is due to the fact that it never swaps
3595             anything except compared values, and it only swaps them when the
3596             compare shows they are out of position.
3597          */
3598          int pc_left, pc_right;
3599          int u_right, u_left;
3600
3601          int s;
3602
3603          pc_left = ((part_left + part_right) / 2);
3604          pc_right = pc_left;
3605          u_right = pc_left - 1;
3606          u_left = pc_right + 1;
3607
3608          /* Qsort works best when the pivot value is also the median value
3609             in the partition (unfortunately you can't find the median value
3610             without first sorting :-), so to give the algorithm a helping
3611             hand, we pick 3 elements and sort them and use the median value
3612             of that tiny set as the pivot value.
3613
3614             Some versions of qsort like to use the left middle and right as
3615             the 3 elements to sort so they can insure the ends of the
3616             partition will contain values which will stop the scan in the
3617             compare loop, but when you have to call an arbitrarily complex
3618             routine to do a compare, its really better to just keep track of
3619             array index values to know when you hit the edge of the
3620             partition and avoid the extra compare. An even better reason to
3621             avoid using a compare call is the fact that you can drop off the
3622             edge of the array if someone foolishly provides you with an
3623             unstable compare function that doesn't always provide consistent
3624             results.
3625
3626             So, since it is simpler for us to compare the three adjacent
3627             elements in the middle of the partition, those are the ones we
3628             pick here (conveniently pointed at by u_right, pc_left, and
3629             u_left). The values of the left, center, and right elements
3630             are refered to as l c and r in the following comments.
3631          */
3632
3633 #ifdef QSORT_ORDER_GUESS
3634          swapped = 0;
3635 #endif
3636          s = qsort_cmp(u_right, pc_left);
3637          if (s < 0) {
3638             /* l < c */
3639             s = qsort_cmp(pc_left, u_left);
3640             /* if l < c, c < r - already in order - nothing to do */
3641             if (s == 0) {
3642                /* l < c, c == r - already in order, pc grows */
3643                ++pc_right;
3644                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3645             } else if (s > 0) {
3646                /* l < c, c > r - need to know more */
3647                s = qsort_cmp(u_right, u_left);
3648                if (s < 0) {
3649                   /* l < c, c > r, l < r - swap c & r to get ordered */
3650                   qsort_swap(pc_left, u_left);
3651                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3652                } else if (s == 0) {
3653                   /* l < c, c > r, l == r - swap c&r, grow pc */
3654                   qsort_swap(pc_left, u_left);
3655                   --pc_left;
3656                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3657                } else {
3658                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3659                   qsort_rotate(pc_left, u_right, u_left);
3660                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3661                }
3662             }
3663          } else if (s == 0) {
3664             /* l == c */
3665             s = qsort_cmp(pc_left, u_left);
3666             if (s < 0) {
3667                /* l == c, c < r - already in order, grow pc */
3668                --pc_left;
3669                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3670             } else if (s == 0) {
3671                /* l == c, c == r - already in order, grow pc both ways */
3672                --pc_left;
3673                ++pc_right;
3674                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3675             } else {
3676                /* l == c, c > r - swap l & r, grow pc */
3677                qsort_swap(u_right, u_left);
3678                ++pc_right;
3679                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3680             }
3681          } else {
3682             /* l > c */
3683             s = qsort_cmp(pc_left, u_left);
3684             if (s < 0) {
3685                /* l > c, c < r - need to know more */
3686                s = qsort_cmp(u_right, u_left);
3687                if (s < 0) {
3688                   /* l > c, c < r, l < r - swap l & c to get ordered */
3689                   qsort_swap(u_right, pc_left);
3690                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3691                } else if (s == 0) {
3692                   /* l > c, c < r, l == r - swap l & c, grow pc */
3693                   qsort_swap(u_right, pc_left);
3694                   ++pc_right;
3695                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3696                } else {
3697                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3698                   qsort_rotate(u_right, pc_left, u_left);
3699                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3700                }
3701             } else if (s == 0) {
3702                /* l > c, c == r - swap ends, grow pc */
3703                qsort_swap(u_right, u_left);
3704                --pc_left;
3705                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3706             } else {
3707                /* l > c, c > r - swap ends to get in order */
3708                qsort_swap(u_right, u_left);
3709                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3710             }
3711          }
3712          /* We now know the 3 middle elements have been compared and
3713             arranged in the desired order, so we can shrink the uncompared
3714             sets on both sides
3715          */
3716          --u_right;
3717          ++u_left;
3718          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3719
3720          /* The above massive nested if was the simple part :-). We now have
3721             the middle 3 elements ordered and we need to scan through the
3722             uncompared sets on either side, swapping elements that are on
3723             the wrong side or simply shuffling equal elements around to get
3724             all equal elements into the pivot chunk.
3725          */
3726
3727          for ( ; ; ) {
3728             int still_work_on_left;
3729             int still_work_on_right;
3730
3731             /* Scan the uncompared values on the left. If I find a value
3732                equal to the pivot value, move it over so it is adjacent to
3733                the pivot chunk and expand the pivot chunk. If I find a value
3734                less than the pivot value, then just leave it - its already
3735                on the correct side of the partition. If I find a greater
3736                value, then stop the scan.
3737             */
3738             while (still_work_on_left = (u_right >= part_left)) {
3739                s = qsort_cmp(u_right, pc_left);
3740                if (s < 0) {
3741                   --u_right;
3742                } else if (s == 0) {
3743                   --pc_left;
3744                   if (pc_left != u_right) {
3745                      qsort_swap(u_right, pc_left);
3746                   }
3747                   --u_right;
3748                } else {
3749                   break;
3750                }
3751                qsort_assert(u_right < pc_left);
3752                qsort_assert(pc_left <= pc_right);
3753                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3754                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3755             }
3756
3757             /* Do a mirror image scan of uncompared values on the right
3758             */
3759             while (still_work_on_right = (u_left <= part_right)) {
3760                s = qsort_cmp(pc_right, u_left);
3761                if (s < 0) {
3762                   ++u_left;
3763                } else if (s == 0) {
3764                   ++pc_right;
3765                   if (pc_right != u_left) {
3766                      qsort_swap(pc_right, u_left);
3767                   }
3768                   ++u_left;
3769                } else {
3770                   break;
3771                }
3772                qsort_assert(u_left > pc_right);
3773                qsort_assert(pc_left <= pc_right);
3774                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3775                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3776             }
3777
3778             if (still_work_on_left) {
3779                /* I know I have a value on the left side which needs to be
3780                   on the right side, but I need to know more to decide
3781                   exactly the best thing to do with it.
3782                */
3783                if (still_work_on_right) {
3784                   /* I know I have values on both side which are out of
3785                      position. This is a big win because I kill two birds
3786                      with one swap (so to speak). I can advance the
3787                      uncompared pointers on both sides after swapping both
3788                      of them into the right place.
3789                   */
3790                   qsort_swap(u_right, u_left);
3791                   --u_right;
3792                   ++u_left;
3793                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3794                } else {
3795                   /* I have an out of position value on the left, but the
3796                      right is fully scanned, so I "slide" the pivot chunk
3797                      and any less-than values left one to make room for the
3798                      greater value over on the right. If the out of position
3799                      value is immediately adjacent to the pivot chunk (there
3800                      are no less-than values), I can do that with a swap,
3801                      otherwise, I have to rotate one of the less than values
3802                      into the former position of the out of position value
3803                      and the right end of the pivot chunk into the left end
3804                      (got all that?).
3805                   */
3806                   --pc_left;
3807                   if (pc_left == u_right) {
3808                      qsort_swap(u_right, pc_right);
3809                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3810                   } else {
3811                      qsort_rotate(u_right, pc_left, pc_right);
3812                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3813                   }
3814                   --pc_right;
3815                   --u_right;
3816                }
3817             } else if (still_work_on_right) {
3818                /* Mirror image of complex case above: I have an out of
3819                   position value on the right, but the left is fully
3820                   scanned, so I need to shuffle things around to make room
3821                   for the right value on the left.
3822                */
3823                ++pc_right;
3824                if (pc_right == u_left) {
3825                   qsort_swap(u_left, pc_left);
3826                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3827                } else {
3828                   qsort_rotate(pc_right, pc_left, u_left);
3829                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3830                }
3831                ++pc_left;
3832                ++u_left;
3833             } else {
3834                /* No more scanning required on either side of partition,
3835                   break out of loop and figure out next set of partitions
3836                */
3837                break;
3838             }
3839          }
3840
3841          /* The elements in the pivot chunk are now in the right place. They
3842             will never move or be compared again. All I have to do is decide
3843             what to do with the stuff to the left and right of the pivot
3844             chunk.
3845
3846             Notes on the QSORT_ORDER_GUESS ifdef code:
3847
3848             1. If I just built these partitions without swapping any (or
3849                very many) elements, there is a chance that the elements are
3850                already ordered properly (being properly ordered will
3851                certainly result in no swapping, but the converse can't be
3852                proved :-).
3853
3854             2. A (properly written) insertion sort will run faster on
3855                already ordered data than qsort will.
3856
3857             3. Perhaps there is some way to make a good guess about
3858                switching to an insertion sort earlier than partition size 6
3859                (for instance - we could save the partition size on the stack
3860                and increase the size each time we find we didn't swap, thus
3861                switching to insertion sort earlier for partitions with a
3862                history of not swapping).
3863
3864             4. Naturally, if I just switch right away, it will make
3865                artificial benchmarks with pure ascending (or descending)
3866                data look really good, but is that a good reason in general?
3867                Hard to say...
3868          */
3869
3870 #ifdef QSORT_ORDER_GUESS
3871          if (swapped < 3) {
3872 #if QSORT_ORDER_GUESS == 1
3873             qsort_break_even = (part_right - part_left) + 1;
3874 #endif
3875 #if QSORT_ORDER_GUESS == 2
3876             qsort_break_even *= 2;
3877 #endif
3878 #if QSORT_ORDER_GUESS == 3
3879             int prev_break = qsort_break_even;
3880             qsort_break_even *= qsort_break_even;
3881             if (qsort_break_even < prev_break) {
3882                qsort_break_even = (part_right - part_left) + 1;
3883             }
3884 #endif
3885          } else {
3886             qsort_break_even = QSORT_BREAK_EVEN;
3887          }
3888 #endif
3889
3890          if (part_left < pc_left) {
3891             /* There are elements on the left which need more processing.
3892                Check the right as well before deciding what to do.
3893             */
3894             if (pc_right < part_right) {
3895                /* We have two partitions to be sorted. Stack the biggest one
3896                   and process the smallest one on the next iteration. This
3897                   minimizes the stack height by insuring that any additional
3898                   stack entries must come from the smallest partition which
3899                   (because it is smallest) will have the fewest
3900                   opportunities to generate additional stack entries.
3901                */
3902                if ((part_right - pc_right) > (pc_left - part_left)) {
3903                   /* stack the right partition, process the left */
3904                   partition_stack[next_stack_entry].left = pc_right + 1;
3905                   partition_stack[next_stack_entry].right = part_right;
3906 #ifdef QSORT_ORDER_GUESS
3907                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3908 #endif
3909                   part_right = pc_left - 1;
3910                } else {
3911                   /* stack the left partition, process the right */
3912                   partition_stack[next_stack_entry].left = part_left;
3913                   partition_stack[next_stack_entry].right = pc_left - 1;
3914 #ifdef QSORT_ORDER_GUESS
3915                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3916 #endif
3917                   part_left = pc_right + 1;
3918                }
3919                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3920                ++next_stack_entry;
3921             } else {
3922                /* The elements on the left are the only remaining elements
3923                   that need sorting, arrange for them to be processed as the
3924                   next partition.
3925                */
3926                part_right = pc_left - 1;
3927             }
3928          } else if (pc_right < part_right) {
3929             /* There is only one chunk on the right to be sorted, make it
3930                the new partition and loop back around.
3931             */
3932             part_left = pc_right + 1;
3933          } else {
3934             /* This whole partition wound up in the pivot chunk, so
3935                we need to get a new partition off the stack.
3936             */
3937             if (next_stack_entry == 0) {
3938                /* the stack is empty - we are done */
3939                break;
3940             }
3941             --next_stack_entry;
3942             part_left = partition_stack[next_stack_entry].left;
3943             part_right = partition_stack[next_stack_entry].right;
3944 #ifdef QSORT_ORDER_GUESS
3945             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3946 #endif
3947          }
3948       } else {
3949          /* This partition is too small to fool with qsort complexity, just
3950             do an ordinary insertion sort to minimize overhead.
3951          */
3952          int i;
3953          /* Assume 1st element is in right place already, and start checking
3954             at 2nd element to see where it should be inserted.
3955          */
3956          for (i = part_left + 1; i <= part_right; ++i) {
3957             int j;
3958             /* Scan (backwards - just in case 'i' is already in right place)
3959                through the elements already sorted to see if the ith element
3960                belongs ahead of one of them.
3961             */
3962             for (j = i - 1; j >= part_left; --j) {
3963                if (qsort_cmp(i, j) >= 0) {
3964                   /* i belongs right after j
3965                   */
3966                   break;
3967                }
3968             }
3969             ++j;
3970             if (j != i) {
3971                /* Looks like we really need to move some things
3972                */
3973                int k;
3974                temp = array[i];
3975                for (k = i - 1; k >= j; --k)
3976                   array[k + 1] = array[k];
3977                array[j] = temp;
3978             }
3979          }
3980
3981          /* That partition is now sorted, grab the next one, or get out
3982             of the loop if there aren't any more.
3983          */
3984
3985          if (next_stack_entry == 0) {
3986             /* the stack is empty - we are done */
3987             break;
3988          }
3989          --next_stack_entry;
3990          part_left = partition_stack[next_stack_entry].left;
3991          part_right = partition_stack[next_stack_entry].right;
3992 #ifdef QSORT_ORDER_GUESS
3993          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3994 #endif
3995       }
3996    }
3997
3998    /* Believe it or not, the array is sorted at this point! */
3999 }