pp_ctl.c

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