pp_ctl.c

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