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