pp_ctl.c

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