pp_ctl.c

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