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