pp_ctl.c

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