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 {
2142                                 av_store(newpad, ix, sv = NEWSV(0,0));
2143                                 SvPADTMP_on(sv);
2144                             }
2145                         }
2146                         if (cx->blk_sub.hasargs) {
2147                             AV* av = newAV();
2148                             av_extend(av, 0);
2149                             av_store(newpad, 0, (SV*)av);
2150                             AvFLAGS(av) = AVf_REIFY;
2151                         }
2152                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2153                         AvFILLp(padlist) = CvDEPTH(cv);
2154                         svp = AvARRAY(padlist);
2155                     }
2156                 }
2157 #ifdef USE_THREADS
2158                 if (!cx->blk_sub.hasargs) {
2159                     AV* av = (AV*)PL_curpad[0];
2160
2161                     items = AvFILLp(av) + 1;
2162                     if (items) {
2163                         /* Mark is at the end of the stack. */
2164                         EXTEND(SP, items);
2165                         Copy(AvARRAY(av), SP + 1, items, SV*);
2166                         SP += items;
2167                         PUTBACK ;
2168                     }
2169                 }
2170 #endif /* USE_THREADS */
2171                 SAVESPTR(PL_curpad);
2172                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2173 #ifndef USE_THREADS
2174                 if (cx->blk_sub.hasargs)
2175 #endif /* USE_THREADS */
2176                 {
2177                     AV* av = (AV*)PL_curpad[0];
2178                     SV** ary;
2179
2180 #ifndef USE_THREADS
2181                     cx->blk_sub.savearray = GvAV(PL_defgv);
2182                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2183 #endif /* USE_THREADS */
2184                     cx->blk_sub.argarray = av;
2185                     ++mark;
2186
2187                     if (items >= AvMAX(av) + 1) {
2188                         ary = AvALLOC(av);
2189                         if (AvARRAY(av) != ary) {
2190                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2191                             SvPVX(av) = (char*)ary;
2192                         }
2193                         if (items >= AvMAX(av) + 1) {
2194                             AvMAX(av) = items - 1;
2195                             Renew(ary,items+1,SV*);
2196                             AvALLOC(av) = ary;
2197                             SvPVX(av) = (char*)ary;
2198                         }
2199                     }
2200                     Copy(mark,AvARRAY(av),items,SV*);
2201                     AvFILLp(av) = items - 1;
2202                     assert(!AvREAL(av));
2203                     while (items--) {
2204                         if (*mark)
2205                             SvTEMP_off(*mark);
2206                         mark++;
2207                     }
2208                 }
2209                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2210                     /*
2211                      * We do not care about using sv to call CV;
2212                      * it's for informational purposes only.
2213                      */
2214                     SV *sv = GvSV(PL_DBsub);
2215                     CV *gotocv;
2216
2217                     if (PERLDB_SUB_NN) {
2218                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2219                     } else {
2220                         save_item(sv);
2221                         gv_efullname3(sv, CvGV(cv), Nullch);
2222                     }
2223                     if (  PERLDB_GOTO
2224                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2225                         PUSHMARK( PL_stack_sp );
2226                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2227                         PL_stack_sp--;
2228                     }
2229                 }
2230                 RETURNOP(CvSTART(cv));
2231             }
2232         }
2233         else {
2234             label = SvPV(sv,n_a);
2235             if (!(do_dump || *label))
2236                 DIE(aTHX_ must_have_label);
2237         }
2238     }
2239     else if (PL_op->op_flags & OPf_SPECIAL) {
2240         if (! do_dump)
2241             DIE(aTHX_ must_have_label);
2242     }
2243     else
2244         label = cPVOP->op_pv;
2245
2246     if (label && *label) {
2247         OP *gotoprobe = 0;
2248
2249         /* find label */
2250
2251         PL_lastgotoprobe = 0;
2252         *enterops = 0;
2253         for (ix = cxstack_ix; ix >= 0; ix--) {
2254             cx = &cxstack[ix];
2255             switch (CxTYPE(cx)) {
2256             case CXt_EVAL:
2257                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2258                 break;
2259             case CXt_LOOP:
2260                 gotoprobe = cx->blk_oldcop->op_sibling;
2261                 break;
2262             case CXt_SUBST:
2263                 continue;
2264             case CXt_BLOCK:
2265                 if (ix)
2266                     gotoprobe = cx->blk_oldcop->op_sibling;
2267                 else
2268                     gotoprobe = PL_main_root;
2269                 break;
2270             case CXt_SUB:
2271                 if (CvDEPTH(cx->blk_sub.cv)) {
2272                     gotoprobe = CvROOT(cx->blk_sub.cv);
2273                     break;
2274                 }
2275                 /* FALL THROUGH */
2276             case CXt_NULL:
2277                 DIE(aTHX_ "Can't \"goto\" outside a block");
2278             default:
2279                 if (ix)
2280                     DIE(aTHX_ "panic: goto");
2281                 gotoprobe = PL_main_root;
2282                 break;
2283             }
2284             retop = dofindlabel(gotoprobe, label,
2285                                 enterops, enterops + GOTO_DEPTH);
2286             if (retop)
2287                 break;
2288             PL_lastgotoprobe = gotoprobe;
2289         }
2290         if (!retop)
2291             DIE(aTHX_ "Can't find label %s", label);
2292
2293         /* pop unwanted frames */
2294
2295         if (ix < cxstack_ix) {
2296             I32 oldsave;
2297
2298             if (ix < 0)
2299                 ix = 0;
2300             dounwind(ix);
2301             TOPBLOCK(cx);
2302             oldsave = PL_scopestack[PL_scopestack_ix];
2303             LEAVE_SCOPE(oldsave);
2304         }
2305
2306         /* push wanted frames */
2307
2308         if (*enterops && enterops[1]) {
2309             OP *oldop = PL_op;
2310             for (ix = 1; enterops[ix]; ix++) {
2311                 PL_op = enterops[ix];
2312                 /* Eventually we may want to stack the needed arguments
2313                  * for each op.  For now, we punt on the hard ones. */
2314                 if (PL_op->op_type == OP_ENTERITER)
2315                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2316                         label);
2317                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2318             }
2319             PL_op = oldop;
2320         }
2321     }
2322
2323     if (do_dump) {
2324 #ifdef VMS
2325         if (!retop) retop = PL_main_start;
2326 #endif
2327         PL_restartop = retop;
2328         PL_do_undump = TRUE;
2329
2330         my_unexec();
2331
2332         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2333         PL_do_undump = FALSE;
2334     }
2335
2336     RETURNOP(retop);
2337 }
2338
2339 PP(pp_exit)
2340 {
2341     djSP;
2342     I32 anum;
2343
2344     if (MAXARG < 1)
2345         anum = 0;
2346     else {
2347         anum = SvIVx(POPs);
2348 #ifdef VMSISH_EXIT
2349         if (anum == 1 && VMSISH_EXIT)
2350             anum = 0;
2351 #endif
2352     }
2353     my_exit(anum);
2354     PUSHs(&PL_sv_undef);
2355     RETURN;
2356 }
2357
2358 #ifdef NOTYET
2359 PP(pp_nswitch)
2360 {
2361     djSP;
2362     NV value = SvNVx(GvSV(cCOP->cop_gv));
2363     register I32 match = I_32(value);
2364
2365     if (value < 0.0) {
2366         if (((NV)match) > value)
2367             --match;            /* was fractional--truncate other way */
2368     }
2369     match -= cCOP->uop.scop.scop_offset;
2370     if (match < 0)
2371         match = 0;
2372     else if (match > cCOP->uop.scop.scop_max)
2373         match = cCOP->uop.scop.scop_max;
2374     PL_op = cCOP->uop.scop.scop_next[match];
2375     RETURNOP(PL_op);
2376 }
2377
2378 PP(pp_cswitch)
2379 {
2380     djSP;
2381     register I32 match;
2382
2383     if (PL_multiline)
2384         PL_op = PL_op->op_next;                 /* can't assume anything */
2385     else {
2386         STRLEN n_a;
2387         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2388         match -= cCOP->uop.scop.scop_offset;
2389         if (match < 0)
2390             match = 0;
2391         else if (match > cCOP->uop.scop.scop_max)
2392             match = cCOP->uop.scop.scop_max;
2393         PL_op = cCOP->uop.scop.scop_next[match];
2394     }
2395     RETURNOP(PL_op);
2396 }
2397 #endif
2398
2399 /* Eval. */
2400
2401 STATIC void
2402 S_save_lines(pTHX_ AV *array, SV *sv)
2403 {
2404     register char *s = SvPVX(sv);
2405     register char *send = SvPVX(sv) + SvCUR(sv);
2406     register char *t;
2407     register I32 line = 1;
2408
2409     while (s && s < send) {
2410         SV *tmpstr = NEWSV(85,0);
2411
2412         sv_upgrade(tmpstr, SVt_PVMG);
2413         t = strchr(s, '\n');
2414         if (t)
2415             t++;
2416         else
2417             t = send;
2418
2419         sv_setpvn(tmpstr, s, t - s);
2420         av_store(array, line++, tmpstr);
2421         s = t;
2422     }
2423 }
2424
2425 STATIC void *
2426 S_docatch_body(pTHX_ va_list args)
2427 {
2428     CALLRUNOPS(aTHX);
2429     return NULL;
2430 }
2431
2432 STATIC OP *
2433 S_docatch(pTHX_ OP *o)
2434 {
2435     dTHR;
2436     int ret;
2437     OP *oldop = PL_op;
2438     volatile PERL_SI *cursi = PL_curstackinfo;
2439     dJMPENV;
2440
2441 #ifdef DEBUGGING
2442     assert(CATCH_GET == TRUE);
2443 #endif
2444     PL_op = o;
2445  redo_body:
2446     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2447     switch (ret) {
2448     case 0:
2449         break;
2450     case 3:
2451         if (PL_restartop && cursi == PL_curstackinfo) {
2452             PL_op = PL_restartop;
2453             PL_restartop = 0;
2454             goto redo_body;
2455         }
2456         /* FALL THROUGH */
2457     default:
2458         PL_op = oldop;
2459         JMPENV_JUMP(ret);
2460         /* NOTREACHED */
2461     }
2462     PL_op = oldop;
2463     return Nullop;
2464 }
2465
2466 OP *
2467 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2468 /* sv Text to convert to OP tree. */
2469 /* startop op_free() this to undo. */
2470 /* code Short string id of the caller. */
2471 {
2472     dSP;                                /* Make POPBLOCK work. */
2473     PERL_CONTEXT *cx;
2474     SV **newsp;
2475     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2476     I32 optype;
2477     OP dummy;
2478     OP *oop = PL_op, *rop;
2479     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2480     char *safestr;
2481
2482     ENTER;
2483     lex_start(sv);
2484     SAVETMPS;
2485     /* switch to eval mode */
2486
2487     if (PL_curcop == &PL_compiling) {
2488         SAVESPTR(PL_compiling.cop_stash);
2489         PL_compiling.cop_stash = PL_curstash;
2490     }
2491     SAVESPTR(CopFILEGV(&PL_compiling));
2492     SAVEI16(PL_compiling.cop_line);
2493     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2494     CopFILEGV_set(&PL_compiling, gv_fetchfile(tmpbuf+2));
2495     PL_compiling.cop_line = 1;
2496     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2497        deleting the eval's FILEGV from the stash before gv_check() runs
2498        (i.e. before run-time proper). To work around the coredump that
2499        ensues, we always turn GvMULTI_on for any globals that were
2500        introduced within evals. See force_ident(). GSAR 96-10-12 */
2501     safestr = savepv(tmpbuf);
2502     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2503     SAVEHINTS();
2504 #ifdef OP_IN_REGISTER
2505     PL_opsave = op;
2506 #else
2507     SAVEPPTR(PL_op);
2508 #endif
2509     PL_hints = 0;
2510
2511     PL_op = &dummy;
2512     PL_op->op_type = OP_ENTEREVAL;
2513     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2514     PUSHBLOCK(cx, CXt_EVAL, SP);
2515     PUSHEVAL(cx, 0, Nullgv);
2516     rop = doeval(G_SCALAR, startop);
2517     POPBLOCK(cx,PL_curpm);
2518     POPEVAL(cx);
2519
2520     (*startop)->op_type = OP_NULL;
2521     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2522     lex_end();
2523     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2524     LEAVE;
2525     if (PL_curcop == &PL_compiling)
2526         PL_compiling.op_private = PL_hints;
2527 #ifdef OP_IN_REGISTER
2528     op = PL_opsave;
2529 #endif
2530     return rop;
2531 }
2532
2533 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2534 STATIC OP *
2535 S_doeval(pTHX_ int gimme, OP** startop)
2536 {
2537     dSP;
2538     OP *saveop = PL_op;
2539     HV *newstash;
2540     CV *caller;
2541     AV* comppadlist;
2542     I32 i;
2543
2544     PL_in_eval = EVAL_INEVAL;
2545
2546     PUSHMARK(SP);
2547
2548     /* set up a scratch pad */
2549
2550     SAVEI32(PL_padix);
2551     SAVESPTR(PL_curpad);
2552     SAVESPTR(PL_comppad);
2553     SAVESPTR(PL_comppad_name);
2554     SAVEI32(PL_comppad_name_fill);
2555     SAVEI32(PL_min_intro_pending);
2556     SAVEI32(PL_max_intro_pending);
2557
2558     caller = PL_compcv;
2559     for (i = cxstack_ix - 1; i >= 0; i--) {
2560         PERL_CONTEXT *cx = &cxstack[i];
2561         if (CxTYPE(cx) == CXt_EVAL)
2562             break;
2563         else if (CxTYPE(cx) == CXt_SUB) {
2564             caller = cx->blk_sub.cv;
2565             break;
2566         }
2567     }
2568
2569     SAVESPTR(PL_compcv);
2570     PL_compcv = (CV*)NEWSV(1104,0);
2571     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2572     CvEVAL_on(PL_compcv);
2573 #ifdef USE_THREADS
2574     CvOWNER(PL_compcv) = 0;
2575     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2576     MUTEX_INIT(CvMUTEXP(PL_compcv));
2577 #endif /* USE_THREADS */
2578
2579     PL_comppad = newAV();
2580     av_push(PL_comppad, Nullsv);
2581     PL_curpad = AvARRAY(PL_comppad);
2582     PL_comppad_name = newAV();
2583     PL_comppad_name_fill = 0;
2584     PL_min_intro_pending = 0;
2585     PL_padix = 0;
2586 #ifdef USE_THREADS
2587     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2588     PL_curpad[0] = (SV*)newAV();
2589     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2590 #endif /* USE_THREADS */
2591
2592     comppadlist = newAV();
2593     AvREAL_off(comppadlist);
2594     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2595     av_store(comppadlist, 1, (SV*)PL_comppad);
2596     CvPADLIST(PL_compcv) = comppadlist;
2597
2598     if (!saveop || saveop->op_type != OP_REQUIRE)
2599         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2600
2601     SAVEFREESV(PL_compcv);
2602
2603     /* make sure we compile in the right package */
2604
2605     newstash = PL_curcop->cop_stash;
2606     if (PL_curstash != newstash) {
2607         SAVESPTR(PL_curstash);
2608         PL_curstash = newstash;
2609     }
2610     SAVESPTR(PL_beginav);
2611     PL_beginav = newAV();
2612     SAVEFREESV(PL_beginav);
2613
2614     /* try to compile it */
2615
2616     PL_eval_root = Nullop;
2617     PL_error_count = 0;
2618     PL_curcop = &PL_compiling;
2619     PL_curcop->cop_arybase = 0;
2620     SvREFCNT_dec(PL_rs);
2621     PL_rs = newSVpvn("\n", 1);
2622     if (saveop && saveop->op_flags & OPf_SPECIAL)
2623         PL_in_eval |= EVAL_KEEPERR;
2624     else
2625         sv_setpv(ERRSV,"");
2626     if (yyparse() || PL_error_count || !PL_eval_root) {
2627         SV **newsp;
2628         I32 gimme;
2629         PERL_CONTEXT *cx;
2630         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2631         STRLEN n_a;
2632
2633         PL_op = saveop;
2634         if (PL_eval_root) {
2635             op_free(PL_eval_root);
2636             PL_eval_root = Nullop;
2637         }
2638         SP = PL_stack_base + POPMARK;           /* pop original mark */
2639         if (!startop) {
2640             POPBLOCK(cx,PL_curpm);
2641             POPEVAL(cx);
2642             pop_return();
2643         }
2644         lex_end();
2645         LEAVE;
2646         if (optype == OP_REQUIRE) {
2647             char* msg = SvPVx(ERRSV, n_a);
2648             DIE(aTHX_ "%sCompilation failed in require",
2649                 *msg ? msg : "Unknown error\n");
2650         }
2651         else if (startop) {
2652             char* msg = SvPVx(ERRSV, n_a);
2653
2654             POPBLOCK(cx,PL_curpm);
2655             POPEVAL(cx);
2656             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2657                        (*msg ? msg : "Unknown error\n"));
2658         }
2659         SvREFCNT_dec(PL_rs);
2660         PL_rs = SvREFCNT_inc(PL_nrs);
2661 #ifdef USE_THREADS
2662         MUTEX_LOCK(&PL_eval_mutex);
2663         PL_eval_owner = 0;
2664         COND_SIGNAL(&PL_eval_cond);
2665         MUTEX_UNLOCK(&PL_eval_mutex);
2666 #endif /* USE_THREADS */
2667         RETPUSHUNDEF;
2668     }
2669     SvREFCNT_dec(PL_rs);
2670     PL_rs = SvREFCNT_inc(PL_nrs);
2671     PL_compiling.cop_line = 0;
2672     if (startop) {
2673         *startop = PL_eval_root;
2674         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2675         CvOUTSIDE(PL_compcv) = Nullcv;
2676     } else
2677         SAVEFREEOP(PL_eval_root);
2678     if (gimme & G_VOID)
2679         scalarvoid(PL_eval_root);
2680     else if (gimme & G_ARRAY)
2681         list(PL_eval_root);
2682     else
2683         scalar(PL_eval_root);
2684
2685     DEBUG_x(dump_eval());
2686
2687     /* Register with debugger: */
2688     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2689         CV *cv = get_cv("DB::postponed", FALSE);
2690         if (cv) {
2691             dSP;
2692             PUSHMARK(SP);
2693             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2694             PUTBACK;
2695             call_sv((SV*)cv, G_DISCARD);
2696         }
2697     }
2698
2699     /* compiled okay, so do it */
2700
2701     CvDEPTH(PL_compcv) = 1;
2702     SP = PL_stack_base + POPMARK;               /* pop original mark */
2703     PL_op = saveop;                     /* The caller may need it. */
2704 #ifdef USE_THREADS
2705     MUTEX_LOCK(&PL_eval_mutex);
2706     PL_eval_owner = 0;
2707     COND_SIGNAL(&PL_eval_cond);
2708     MUTEX_UNLOCK(&PL_eval_mutex);
2709 #endif /* USE_THREADS */
2710
2711     RETURNOP(PL_eval_start);
2712 }
2713
2714 STATIC PerlIO *
2715 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2716 {
2717     STRLEN namelen = strlen(name);
2718     PerlIO *fp;
2719
2720     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2721         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2722         char *pmc = SvPV_nolen(pmcsv);
2723         Stat_t pmstat;
2724         Stat_t pmcstat;
2725         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2726             fp = PerlIO_open(name, mode);
2727         }
2728         else {
2729             if (PerlLIO_stat(name, &pmstat) < 0 ||
2730                 pmstat.st_mtime < pmcstat.st_mtime)
2731             {
2732                 fp = PerlIO_open(pmc, mode);
2733             }
2734             else {
2735                 fp = PerlIO_open(name, mode);
2736             }
2737         }
2738         SvREFCNT_dec(pmcsv);
2739     }
2740     else {
2741         fp = PerlIO_open(name, mode);
2742     }
2743     return fp;
2744 }
2745
2746 PP(pp_require)
2747 {
2748     djSP;
2749     register PERL_CONTEXT *cx;
2750     SV *sv;
2751     char *name;
2752     STRLEN len;
2753     char *tryname;
2754     SV *namesv = Nullsv;
2755     SV** svp;
2756     I32 gimme = G_SCALAR;
2757     PerlIO *tryrsfp = 0;
2758     STRLEN n_a;
2759     int filter_has_file = 0;
2760     GV *filter_child_proc = 0;
2761     SV *filter_state = 0;
2762     SV *filter_sub = 0;
2763
2764     sv = POPs;
2765     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2766         if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2767             DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2768                 SvPV(sv,n_a),PL_patchlevel);
2769         RETPUSHYES;
2770     }
2771     name = SvPV(sv, len);
2772     if (!(name && len > 0 && *name))
2773         DIE(aTHX_ "Null filename used");
2774     TAINT_PROPER("require");
2775     if (PL_op->op_type == OP_REQUIRE &&
2776       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2777       *svp != &PL_sv_undef)
2778         RETPUSHYES;
2779
2780     /* prepare to compile file */
2781
2782     if (*name == '/' ||
2783         (*name == '.' &&
2784             (name[1] == '/' ||
2785              (name[1] == '.' && name[2] == '/')))
2786 #ifdef DOSISH
2787       || (name[0] && name[1] == ':')
2788 #endif
2789 #ifdef WIN32
2790       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2791 #endif
2792 #ifdef VMS
2793         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2794             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2795 #endif
2796     )
2797     {
2798         tryname = name;
2799         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2800     }
2801     else {
2802         AV *ar = GvAVn(PL_incgv);
2803         I32 i;
2804 #ifdef VMS
2805         char *unixname;
2806         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2807 #endif
2808         {
2809             namesv = NEWSV(806, 0);
2810             for (i = 0; i <= AvFILL(ar); i++) {
2811                 SV *dirsv = *av_fetch(ar, i, TRUE);
2812
2813                 if (SvROK(dirsv)) {
2814                     int count;
2815                     SV *loader = dirsv;
2816
2817                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2818                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2819                     }
2820
2821                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2822                                    PTR2UV(SvANY(loader)), name);
2823                     tryname = SvPVX(namesv);
2824                     tryrsfp = 0;
2825
2826                     ENTER;
2827                     SAVETMPS;
2828                     EXTEND(SP, 2);
2829
2830                     PUSHMARK(SP);
2831                     PUSHs(dirsv);
2832                     PUSHs(sv);
2833                     PUTBACK;
2834                     count = call_sv(loader, G_ARRAY);
2835                     SPAGAIN;
2836
2837                     if (count > 0) {
2838                         int i = 0;
2839                         SV *arg;
2840
2841                         SP -= count - 1;
2842                         arg = SP[i++];
2843
2844                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2845                             arg = SvRV(arg);
2846                         }
2847
2848                         if (SvTYPE(arg) == SVt_PVGV) {
2849                             IO *io = GvIO((GV *)arg);
2850
2851                             ++filter_has_file;
2852
2853                             if (io) {
2854                                 tryrsfp = IoIFP(io);
2855                                 if (IoTYPE(io) == '|') {
2856                                     /* reading from a child process doesn't
2857                                        nest -- when returning from reading
2858                                        the inner module, the outer one is
2859                                        unreadable (closed?)  I've tried to
2860                                        save the gv to manage the lifespan of
2861                                        the pipe, but this didn't help. XXX */
2862                                     filter_child_proc = (GV *)arg;
2863                                     (void)SvREFCNT_inc(filter_child_proc);
2864                                 }
2865                                 else {
2866                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2867                                         PerlIO_close(IoOFP(io));
2868                                     }
2869                                     IoIFP(io) = Nullfp;
2870                                     IoOFP(io) = Nullfp;
2871                                 }
2872                             }
2873
2874                             if (i < count) {
2875                                 arg = SP[i++];
2876                             }
2877                         }
2878
2879                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2880                             filter_sub = arg;
2881                             (void)SvREFCNT_inc(filter_sub);
2882
2883                             if (i < count) {
2884                                 filter_state = SP[i];
2885                                 (void)SvREFCNT_inc(filter_state);
2886                             }
2887
2888                             if (tryrsfp == 0) {
2889                                 tryrsfp = PerlIO_open("/dev/null",
2890                                                       PERL_SCRIPT_MODE);
2891                             }
2892                         }
2893                     }
2894
2895                     PUTBACK;
2896                     FREETMPS;
2897                     LEAVE;
2898
2899                     if (tryrsfp) {
2900                         break;
2901                     }
2902
2903                     filter_has_file = 0;
2904                     if (filter_child_proc) {
2905                         SvREFCNT_dec(filter_child_proc);
2906                         filter_child_proc = 0;
2907                     }
2908                     if (filter_state) {
2909                         SvREFCNT_dec(filter_state);
2910                         filter_state = 0;
2911                     }
2912                     if (filter_sub) {
2913                         SvREFCNT_dec(filter_sub);
2914                         filter_sub = 0;
2915                     }
2916                 }
2917                 else {
2918                     char *dir = SvPVx(dirsv, n_a);
2919 #ifdef VMS
2920                     char *unixdir;
2921                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2922                         continue;
2923                     sv_setpv(namesv, unixdir);
2924                     sv_catpv(namesv, unixname);
2925 #else
2926                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
2927 #endif
2928                     TAINT_PROPER("require");
2929                     tryname = SvPVX(namesv);
2930                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2931                     if (tryrsfp) {
2932                         if (tryname[0] == '.' && tryname[1] == '/')
2933                             tryname += 2;
2934                         break;
2935                     }
2936                 }
2937             }
2938         }
2939     }
2940     SAVESPTR(CopFILEGV(&PL_compiling));
2941     CopFILEGV_set(&PL_compiling, gv_fetchfile(tryrsfp ? tryname : name));
2942     SvREFCNT_dec(namesv);
2943     if (!tryrsfp) {
2944         if (PL_op->op_type == OP_REQUIRE) {
2945             char *msgstr = name;
2946             if (namesv) {                       /* did we lookup @INC? */
2947                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2948                 SV *dirmsgsv = NEWSV(0, 0);
2949                 AV *ar = GvAVn(PL_incgv);
2950                 I32 i;
2951                 sv_catpvn(msg, " in @INC", 8);
2952                 if (instr(SvPVX(msg), ".h "))
2953                     sv_catpv(msg, " (change .h to .ph maybe?)");
2954                 if (instr(SvPVX(msg), ".ph "))
2955                     sv_catpv(msg, " (did you run h2ph?)");
2956                 sv_catpv(msg, " (@INC contains:");
2957                 for (i = 0; i <= AvFILL(ar); i++) {
2958                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2959                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
2960                     sv_catsv(msg, dirmsgsv);
2961                 }
2962                 sv_catpvn(msg, ")", 1);
2963                 SvREFCNT_dec(dirmsgsv);
2964                 msgstr = SvPV_nolen(msg);
2965             }
2966             DIE(aTHX_ "Can't locate %s", msgstr);
2967         }
2968
2969         RETPUSHUNDEF;
2970     }
2971     else
2972         SETERRNO(0, SS$_NORMAL);
2973
2974     /* Assume success here to prevent recursive requirement. */
2975     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2976                    newSVsv(CopFILESV(&PL_compiling)), 0 );
2977
2978     ENTER;
2979     SAVETMPS;
2980     lex_start(sv_2mortal(newSVpvn("",0)));
2981     SAVEGENERICSV(PL_rsfp_filters);
2982     PL_rsfp_filters = Nullav;
2983
2984     PL_rsfp = tryrsfp;
2985     name = savepv(name);
2986     SAVEFREEPV(name);
2987     SAVEHINTS();
2988     PL_hints = 0;
2989     SAVEPPTR(PL_compiling.cop_warnings);
2990     if (PL_dowarn & G_WARN_ALL_ON)
2991         PL_compiling.cop_warnings = WARN_ALL ;
2992     else if (PL_dowarn & G_WARN_ALL_OFF)
2993         PL_compiling.cop_warnings = WARN_NONE ;
2994     else
2995         PL_compiling.cop_warnings = WARN_STD ;
2996
2997     if (filter_sub || filter_child_proc) {
2998         SV *datasv = filter_add(run_user_filter, Nullsv);
2999         IoLINES(datasv) = filter_has_file;
3000         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3001         IoTOP_GV(datasv) = (GV *)filter_state;
3002         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3003     }
3004
3005     /* switch to eval mode */
3006     push_return(PL_op->op_next);
3007     PUSHBLOCK(cx, CXt_EVAL, SP);
3008     PUSHEVAL(cx, name, Nullgv);
3009
3010     SAVEI16(PL_compiling.cop_line);
3011     PL_compiling.cop_line = 0;
3012
3013     PUTBACK;
3014 #ifdef USE_THREADS
3015     MUTEX_LOCK(&PL_eval_mutex);
3016     if (PL_eval_owner && PL_eval_owner != thr)
3017         while (PL_eval_owner)
3018             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3019     PL_eval_owner = thr;
3020     MUTEX_UNLOCK(&PL_eval_mutex);
3021 #endif /* USE_THREADS */
3022     return DOCATCH(doeval(G_SCALAR, NULL));
3023 }
3024
3025 PP(pp_dofile)
3026 {
3027     return pp_require();
3028 }
3029
3030 PP(pp_entereval)
3031 {
3032     djSP;
3033     register PERL_CONTEXT *cx;
3034     dPOPss;
3035     I32 gimme = GIMME_V, was = PL_sub_generation;
3036     char tmpbuf[TYPE_DIGITS(long) + 12];
3037     char *safestr;
3038     STRLEN len;
3039     OP *ret;
3040
3041     if (!SvPV(sv,len) || !len)
3042         RETPUSHUNDEF;
3043     TAINT_PROPER("eval");
3044
3045     ENTER;
3046     lex_start(sv);
3047     SAVETMPS;
3048
3049     /* switch to eval mode */
3050
3051     SAVESPTR(CopFILEGV(&PL_compiling));
3052     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3053     CopFILEGV_set(&PL_compiling, gv_fetchfile(tmpbuf+2));
3054     PL_compiling.cop_line = 1;
3055     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3056        deleting the eval's FILEGV from the stash before gv_check() runs
3057        (i.e. before run-time proper). To work around the coredump that
3058        ensues, we always turn GvMULTI_on for any globals that were
3059        introduced within evals. See force_ident(). GSAR 96-10-12 */
3060     safestr = savepv(tmpbuf);
3061     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3062     SAVEHINTS();
3063     PL_hints = PL_op->op_targ;
3064     SAVEPPTR(PL_compiling.cop_warnings);
3065     if (!specialWARN(PL_compiling.cop_warnings)) {
3066         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3067         SAVEFREESV(PL_compiling.cop_warnings) ;
3068     }
3069
3070     push_return(PL_op->op_next);
3071     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3072     PUSHEVAL(cx, 0, Nullgv);
3073
3074     /* prepare to compile string */
3075
3076     if (PERLDB_LINE && PL_curstash != PL_debstash)
3077         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3078     PUTBACK;
3079 #ifdef USE_THREADS
3080     MUTEX_LOCK(&PL_eval_mutex);
3081     if (PL_eval_owner && PL_eval_owner != thr)
3082         while (PL_eval_owner)
3083             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3084     PL_eval_owner = thr;
3085     MUTEX_UNLOCK(&PL_eval_mutex);
3086 #endif /* USE_THREADS */
3087     ret = doeval(gimme, NULL);
3088     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3089         && ret != PL_op->op_next) {     /* Successive compilation. */
3090         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3091     }
3092     return DOCATCH(ret);
3093 }
3094
3095 PP(pp_leaveeval)
3096 {
3097     djSP;
3098     register SV **mark;
3099     SV **newsp;
3100     PMOP *newpm;
3101     I32 gimme;
3102     register PERL_CONTEXT *cx;
3103     OP *retop;
3104     U8 save_flags = PL_op -> op_flags;
3105     I32 optype;
3106
3107     POPBLOCK(cx,newpm);
3108     POPEVAL(cx);
3109     retop = pop_return();
3110
3111     TAINT_NOT;
3112     if (gimme == G_VOID)
3113         MARK = newsp;
3114     else if (gimme == G_SCALAR) {
3115         MARK = newsp + 1;
3116         if (MARK <= SP) {
3117             if (SvFLAGS(TOPs) & SVs_TEMP)
3118                 *MARK = TOPs;
3119             else
3120                 *MARK = sv_mortalcopy(TOPs);
3121         }
3122         else {
3123             MEXTEND(mark,0);
3124             *MARK = &PL_sv_undef;
3125         }
3126         SP = MARK;
3127     }
3128     else {
3129         /* in case LEAVE wipes old return values */
3130         for (mark = newsp + 1; mark <= SP; mark++) {
3131             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3132                 *mark = sv_mortalcopy(*mark);
3133                 TAINT_NOT;      /* Each item is independent */
3134             }
3135         }
3136     }
3137     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3138
3139     if (AvFILLp(PL_comppad_name) >= 0)
3140         free_closures();
3141
3142 #ifdef DEBUGGING
3143     assert(CvDEPTH(PL_compcv) == 1);
3144 #endif
3145     CvDEPTH(PL_compcv) = 0;
3146     lex_end();
3147
3148     if (optype == OP_REQUIRE &&
3149         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3150     {
3151         /* Unassume the success we assumed earlier. */
3152         char *name = cx->blk_eval.old_name;
3153         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3154         retop = Perl_die(aTHX_ "%s did not return a true value", name);
3155         /* die_where() did LEAVE, or we won't be here */
3156     }
3157     else {
3158         LEAVE;
3159         if (!(save_flags & OPf_SPECIAL))
3160             sv_setpv(ERRSV,"");
3161     }
3162
3163     RETURNOP(retop);
3164 }
3165
3166 PP(pp_entertry)
3167 {
3168     djSP;
3169     register PERL_CONTEXT *cx;
3170     I32 gimme = GIMME_V;
3171
3172     ENTER;
3173     SAVETMPS;
3174
3175     push_return(cLOGOP->op_other->op_next);
3176     PUSHBLOCK(cx, CXt_EVAL, SP);
3177     PUSHEVAL(cx, 0, 0);
3178     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3179
3180     PL_in_eval = EVAL_INEVAL;
3181     sv_setpv(ERRSV,"");
3182     PUTBACK;
3183     return DOCATCH(PL_op->op_next);
3184 }
3185
3186 PP(pp_leavetry)
3187 {
3188     djSP;
3189     register SV **mark;
3190     SV **newsp;
3191     PMOP *newpm;
3192     I32 gimme;
3193     register PERL_CONTEXT *cx;
3194     I32 optype;
3195
3196     POPBLOCK(cx,newpm);
3197     POPEVAL(cx);
3198     pop_return();
3199
3200     TAINT_NOT;
3201     if (gimme == G_VOID)
3202         SP = newsp;
3203     else if (gimme == G_SCALAR) {
3204         MARK = newsp + 1;
3205         if (MARK <= SP) {
3206             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3207                 *MARK = TOPs;
3208             else
3209                 *MARK = sv_mortalcopy(TOPs);
3210         }
3211         else {
3212             MEXTEND(mark,0);
3213             *MARK = &PL_sv_undef;
3214         }
3215         SP = MARK;
3216     }
3217     else {
3218         /* in case LEAVE wipes old return values */
3219         for (mark = newsp + 1; mark <= SP; mark++) {
3220             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3221                 *mark = sv_mortalcopy(*mark);
3222                 TAINT_NOT;      /* Each item is independent */
3223             }
3224         }
3225     }
3226     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3227
3228     LEAVE;
3229     sv_setpv(ERRSV,"");
3230     RETURN;
3231 }
3232
3233 STATIC void
3234 S_doparseform(pTHX_ SV *sv)
3235 {
3236     STRLEN len;
3237     register char *s = SvPV_force(sv, len);
3238     register char *send = s + len;
3239     register char *base;
3240     register I32 skipspaces = 0;
3241     bool noblank;
3242     bool repeat;
3243     bool postspace = FALSE;
3244     U16 *fops;
3245     register U16 *fpc;
3246     U16 *linepc;
3247     register I32 arg;
3248     bool ischop;
3249
3250     if (len == 0)
3251         Perl_croak(aTHX_ "Null picture in formline");
3252
3253     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3254     fpc = fops;
3255
3256     if (s < send) {
3257         linepc = fpc;
3258         *fpc++ = FF_LINEMARK;
3259         noblank = repeat = FALSE;
3260         base = s;
3261     }
3262
3263     while (s <= send) {
3264         switch (*s++) {
3265         default:
3266             skipspaces = 0;
3267             continue;
3268
3269         case '~':
3270             if (*s == '~') {
3271                 repeat = TRUE;
3272                 *s = ' ';
3273             }
3274             noblank = TRUE;
3275             s[-1] = ' ';
3276             /* FALL THROUGH */
3277         case ' ': case '\t':
3278             skipspaces++;
3279             continue;
3280
3281         case '\n': case 0:
3282             arg = s - base;
3283             skipspaces++;
3284             arg -= skipspaces;
3285             if (arg) {
3286                 if (postspace)
3287                     *fpc++ = FF_SPACE;
3288                 *fpc++ = FF_LITERAL;
3289                 *fpc++ = arg;
3290             }
3291             postspace = FALSE;
3292             if (s <= send)
3293                 skipspaces--;
3294             if (skipspaces) {
3295                 *fpc++ = FF_SKIP;
3296                 *fpc++ = skipspaces;
3297             }
3298             skipspaces = 0;
3299             if (s <= send)
3300                 *fpc++ = FF_NEWLINE;
3301             if (noblank) {
3302                 *fpc++ = FF_BLANK;
3303                 if (repeat)
3304                     arg = fpc - linepc + 1;
3305                 else
3306                     arg = 0;
3307                 *fpc++ = arg;
3308             }
3309             if (s < send) {
3310                 linepc = fpc;
3311                 *fpc++ = FF_LINEMARK;
3312                 noblank = repeat = FALSE;
3313                 base = s;
3314             }
3315             else
3316                 s++;
3317             continue;
3318
3319         case '@':
3320         case '^':
3321             ischop = s[-1] == '^';
3322
3323             if (postspace) {
3324                 *fpc++ = FF_SPACE;
3325                 postspace = FALSE;
3326             }
3327             arg = (s - base) - 1;
3328             if (arg) {
3329                 *fpc++ = FF_LITERAL;
3330                 *fpc++ = arg;
3331             }
3332
3333             base = s - 1;
3334             *fpc++ = FF_FETCH;
3335             if (*s == '*') {
3336                 s++;
3337                 *fpc++ = 0;
3338                 *fpc++ = FF_LINEGLOB;
3339             }
3340             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3341                 arg = ischop ? 512 : 0;
3342                 base = s - 1;
3343                 while (*s == '#')
3344                     s++;
3345                 if (*s == '.') {
3346                     char *f;
3347                     s++;
3348                     f = s;
3349                     while (*s == '#')
3350                         s++;
3351                     arg |= 256 + (s - f);
3352                 }
3353                 *fpc++ = s - base;              /* fieldsize for FETCH */
3354                 *fpc++ = FF_DECIMAL;
3355                 *fpc++ = arg;
3356             }
3357             else {
3358                 I32 prespace = 0;
3359                 bool ismore = FALSE;
3360
3361                 if (*s == '>') {
3362                     while (*++s == '>') ;
3363                     prespace = FF_SPACE;
3364                 }
3365                 else if (*s == '|') {
3366                     while (*++s == '|') ;
3367                     prespace = FF_HALFSPACE;
3368                     postspace = TRUE;
3369                 }
3370                 else {
3371                     if (*s == '<')
3372                         while (*++s == '<') ;
3373                     postspace = TRUE;
3374                 }
3375                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3376                     s += 3;
3377                     ismore = TRUE;
3378                 }
3379                 *fpc++ = s - base;              /* fieldsize for FETCH */
3380
3381                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3382
3383                 if (prespace)
3384                     *fpc++ = prespace;
3385                 *fpc++ = FF_ITEM;
3386                 if (ismore)
3387                     *fpc++ = FF_MORE;
3388                 if (ischop)
3389                     *fpc++ = FF_CHOP;
3390             }
3391             base = s;
3392             skipspaces = 0;
3393             continue;
3394         }
3395     }
3396     *fpc++ = FF_END;
3397
3398     arg = fpc - fops;
3399     { /* need to jump to the next word */
3400         int z;
3401         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3402         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3403         s = SvPVX(sv) + SvCUR(sv) + z;
3404     }
3405     Copy(fops, s, arg, U16);
3406     Safefree(fops);
3407     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3408     SvCOMPILED_on(sv);
3409 }
3410
3411 /*
3412  * The rest of this file was derived from source code contributed
3413  * by Tom Horsley.
3414  *
3415  * NOTE: this code was derived from Tom Horsley's qsort replacement
3416  * and should not be confused with the original code.
3417  */
3418
3419 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3420
3421    Permission granted to distribute under the same terms as perl which are
3422    (briefly):
3423
3424     This program is free software; you can redistribute it and/or modify
3425     it under the terms of either:
3426
3427         a) the GNU General Public License as published by the Free
3428         Software Foundation; either version 1, or (at your option) any
3429         later version, or
3430
3431         b) the "Artistic License" which comes with this Kit.
3432
3433    Details on the perl license can be found in the perl source code which
3434    may be located via the www.perl.com web page.
3435
3436    This is the most wonderfulest possible qsort I can come up with (and
3437    still be mostly portable) My (limited) tests indicate it consistently
3438    does about 20% fewer calls to compare than does the qsort in the Visual
3439    C++ library, other vendors may vary.
3440
3441    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3442    others I invented myself (or more likely re-invented since they seemed
3443    pretty obvious once I watched the algorithm operate for a while).
3444
3445    Most of this code was written while watching the Marlins sweep the Giants
3446    in the 1997 National League Playoffs - no Braves fans allowed to use this
3447    code (just kidding :-).
3448
3449    I realize that if I wanted to be true to the perl tradition, the only
3450    comment in this file would be something like:
3451
3452    ...they shuffled back towards the rear of the line. 'No, not at the
3453    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3454
3455    However, I really needed to violate that tradition just so I could keep
3456    track of what happens myself, not to mention some poor fool trying to
3457    understand this years from now :-).
3458 */
3459
3460 /* ********************************************************** Configuration */
3461
3462 #ifndef QSORT_ORDER_GUESS
3463 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3464 #endif
3465
3466 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3467    future processing - a good max upper bound is log base 2 of memory size
3468    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3469    safely be smaller than that since the program is taking up some space and
3470    most operating systems only let you grab some subset of contiguous
3471    memory (not to mention that you are normally sorting data larger than
3472    1 byte element size :-).
3473 */
3474 #ifndef QSORT_MAX_STACK
3475 #define QSORT_MAX_STACK 32
3476 #endif
3477
3478 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3479    Anything bigger and we use qsort. If you make this too small, the qsort
3480    will probably break (or become less efficient), because it doesn't expect
3481    the middle element of a partition to be the same as the right or left -
3482    you have been warned).
3483 */
3484 #ifndef QSORT_BREAK_EVEN
3485 #define QSORT_BREAK_EVEN 6
3486 #endif
3487
3488 /* ************************************************************* Data Types */
3489
3490 /* hold left and right index values of a partition waiting to be sorted (the
3491    partition includes both left and right - right is NOT one past the end or
3492    anything like that).
3493 */
3494 struct partition_stack_entry {
3495    int left;
3496    int right;
3497 #ifdef QSORT_ORDER_GUESS
3498    int qsort_break_even;
3499 #endif
3500 };
3501
3502 /* ******************************************************* Shorthand Macros */
3503
3504 /* Note that these macros will be used from inside the qsort function where
3505    we happen to know that the variable 'elt_size' contains the size of an
3506    array element and the variable 'temp' points to enough space to hold a
3507    temp element and the variable 'array' points to the array being sorted
3508    and 'compare' is the pointer to the compare routine.
3509
3510    Also note that there are very many highly architecture specific ways
3511    these might be sped up, but this is simply the most generally portable
3512    code I could think of.
3513 */
3514
3515 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3516 */
3517 #define qsort_cmp(elt1, elt2) \
3518    ((*compare)(aTHXo_ array[elt1], array[elt2]))
3519
3520 #ifdef QSORT_ORDER_GUESS
3521 #define QSORT_NOTICE_SWAP swapped++;
3522 #else
3523 #define QSORT_NOTICE_SWAP
3524 #endif
3525
3526 /* swaps contents of array elements elt1, elt2.
3527 */
3528 #define qsort_swap(elt1, elt2) \
3529    STMT_START { \
3530       QSORT_NOTICE_SWAP \
3531       temp = array[elt1]; \
3532       array[elt1] = array[elt2]; \
3533       array[elt2] = temp; \
3534    } STMT_END
3535
3536 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3537    elt3 and elt3 gets elt1.
3538 */
3539 #define qsort_rotate(elt1, elt2, elt3) \
3540    STMT_START { \
3541       QSORT_NOTICE_SWAP \
3542       temp = array[elt1]; \
3543       array[elt1] = array[elt2]; \
3544       array[elt2] = array[elt3]; \
3545       array[elt3] = temp; \
3546    } STMT_END
3547
3548 /* ************************************************************ Debug stuff */
3549
3550 #ifdef QSORT_DEBUG
3551
3552 static void
3553 break_here()
3554 {
3555    return; /* good place to set a breakpoint */
3556 }
3557
3558 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3559
3560 static void
3561 doqsort_all_asserts(
3562    void * array,
3563    size_t num_elts,
3564    size_t elt_size,
3565    int (*compare)(const void * elt1, const void * elt2),
3566    int pc_left, int pc_right, int u_left, int u_right)
3567 {
3568    int i;
3569
3570    qsort_assert(pc_left <= pc_right);
3571    qsort_assert(u_right < pc_left);
3572    qsort_assert(pc_right < u_left);
3573    for (i = u_right + 1; i < pc_left; ++i) {
3574       qsort_assert(qsort_cmp(i, pc_left) < 0);
3575    }
3576    for (i = pc_left; i < pc_right; ++i) {
3577       qsort_assert(qsort_cmp(i, pc_right) == 0);
3578    }
3579    for (i = pc_right + 1; i < u_left; ++i) {
3580       qsort_assert(qsort_cmp(pc_right, i) < 0);
3581    }
3582 }
3583
3584 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3585    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3586                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3587
3588 #else
3589
3590 #define qsort_assert(t) ((void)0)
3591
3592 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3593
3594 #endif
3595
3596 /* ****************************************************************** qsort */
3597
3598 STATIC void
3599 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3600 {
3601    register SV * temp;
3602
3603    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3604    int next_stack_entry = 0;
3605
3606    int part_left;
3607    int part_right;
3608 #ifdef QSORT_ORDER_GUESS
3609    int qsort_break_even;
3610    int swapped;
3611 #endif
3612
3613    /* Make sure we actually have work to do.
3614    */
3615    if (num_elts <= 1) {
3616       return;
3617    }
3618
3619    /* Setup the initial partition definition and fall into the sorting loop
3620    */
3621    part_left = 0;
3622    part_right = (int)(num_elts - 1);
3623 #ifdef QSORT_ORDER_GUESS
3624    qsort_break_even = QSORT_BREAK_EVEN;
3625 #else
3626 #define qsort_break_even QSORT_BREAK_EVEN
3627 #endif
3628    for ( ; ; ) {
3629       if ((part_right - part_left) >= qsort_break_even) {
3630          /* OK, this is gonna get hairy, so lets try to document all the
3631             concepts and abbreviations and variables and what they keep
3632             track of:
3633
3634             pc: pivot chunk - the set of array elements we accumulate in the
3635                 middle of the partition, all equal in value to the original
3636                 pivot element selected. The pc is defined by:
3637
3638                 pc_left - the leftmost array index of the pc
3639                 pc_right - the rightmost array index of the pc
3640
3641                 we start with pc_left == pc_right and only one element
3642                 in the pivot chunk (but it can grow during the scan).
3643
3644             u:  uncompared elements - the set of elements in the partition
3645                 we have not yet compared to the pivot value. There are two
3646                 uncompared sets during the scan - one to the left of the pc
3647                 and one to the right.
3648
3649                 u_right - the rightmost index of the left side's uncompared set
3650                 u_left - the leftmost index of the right side's uncompared set
3651
3652                 The leftmost index of the left sides's uncompared set
3653                 doesn't need its own variable because it is always defined
3654                 by the leftmost edge of the whole partition (part_left). The
3655                 same goes for the rightmost edge of the right partition
3656                 (part_right).
3657
3658                 We know there are no uncompared elements on the left once we
3659                 get u_right < part_left and no uncompared elements on the
3660                 right once u_left > part_right. When both these conditions
3661                 are met, we have completed the scan of the partition.
3662
3663                 Any elements which are between the pivot chunk and the
3664                 uncompared elements should be less than the pivot value on
3665                 the left side and greater than the pivot value on the right
3666                 side (in fact, the goal of the whole algorithm is to arrange
3667                 for that to be true and make the groups of less-than and
3668                 greater-then elements into new partitions to sort again).
3669
3670             As you marvel at the complexity of the code and wonder why it
3671             has to be so confusing. Consider some of the things this level
3672             of confusion brings:
3673
3674             Once I do a compare, I squeeze every ounce of juice out of it. I
3675             never do compare calls I don't have to do, and I certainly never
3676             do redundant calls.
3677
3678             I also never swap any elements unless I can prove there is a
3679             good reason. Many sort algorithms will swap a known value with
3680             an uncompared value just to get things in the right place (or
3681             avoid complexity :-), but that uncompared value, once it gets
3682             compared, may then have to be swapped again. A lot of the
3683             complexity of this code is due to the fact that it never swaps
3684             anything except compared values, and it only swaps them when the
3685             compare shows they are out of position.
3686          */
3687          int pc_left, pc_right;
3688          int u_right, u_left;
3689
3690          int s;
3691
3692          pc_left = ((part_left + part_right) / 2);
3693          pc_right = pc_left;
3694          u_right = pc_left - 1;
3695          u_left = pc_right + 1;
3696
3697          /* Qsort works best when the pivot value is also the median value
3698             in the partition (unfortunately you can't find the median value
3699             without first sorting :-), so to give the algorithm a helping
3700             hand, we pick 3 elements and sort them and use the median value
3701             of that tiny set as the pivot value.
3702
3703             Some versions of qsort like to use the left middle and right as
3704             the 3 elements to sort so they can insure the ends of the
3705             partition will contain values which will stop the scan in the
3706             compare loop, but when you have to call an arbitrarily complex
3707             routine to do a compare, its really better to just keep track of
3708             array index values to know when you hit the edge of the
3709             partition and avoid the extra compare. An even better reason to
3710             avoid using a compare call is the fact that you can drop off the
3711             edge of the array if someone foolishly provides you with an
3712             unstable compare function that doesn't always provide consistent
3713             results.
3714
3715             So, since it is simpler for us to compare the three adjacent
3716             elements in the middle of the partition, those are the ones we
3717             pick here (conveniently pointed at by u_right, pc_left, and
3718             u_left). The values of the left, center, and right elements
3719             are refered to as l c and r in the following comments.
3720          */
3721
3722 #ifdef QSORT_ORDER_GUESS
3723          swapped = 0;
3724 #endif
3725          s = qsort_cmp(u_right, pc_left);
3726          if (s < 0) {
3727             /* l < c */
3728             s = qsort_cmp(pc_left, u_left);
3729             /* if l < c, c < r - already in order - nothing to do */
3730             if (s == 0) {
3731                /* l < c, c == r - already in order, pc grows */
3732                ++pc_right;
3733                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3734             } else if (s > 0) {
3735                /* l < c, c > r - need to know more */
3736                s = qsort_cmp(u_right, u_left);
3737                if (s < 0) {
3738                   /* l < c, c > r, l < r - swap c & r to get ordered */
3739                   qsort_swap(pc_left, u_left);
3740                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3741                } else if (s == 0) {
3742                   /* l < c, c > r, l == r - swap c&r, grow pc */
3743                   qsort_swap(pc_left, u_left);
3744                   --pc_left;
3745                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3746                } else {
3747                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3748                   qsort_rotate(pc_left, u_right, u_left);
3749                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3750                }
3751             }
3752          } else if (s == 0) {
3753             /* l == c */
3754             s = qsort_cmp(pc_left, u_left);
3755             if (s < 0) {
3756                /* l == c, c < r - already in order, grow pc */
3757                --pc_left;
3758                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3759             } else if (s == 0) {
3760                /* l == c, c == r - already in order, grow pc both ways */
3761                --pc_left;
3762                ++pc_right;
3763                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3764             } else {
3765                /* l == c, c > r - swap l & r, grow pc */
3766                qsort_swap(u_right, u_left);
3767                ++pc_right;
3768                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3769             }
3770          } else {
3771             /* l > c */
3772             s = qsort_cmp(pc_left, u_left);
3773             if (s < 0) {
3774                /* l > c, c < r - need to know more */
3775                s = qsort_cmp(u_right, u_left);
3776                if (s < 0) {
3777                   /* l > c, c < r, l < r - swap l & c to get ordered */
3778                   qsort_swap(u_right, pc_left);
3779                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3780                } else if (s == 0) {
3781                   /* l > c, c < r, l == r - swap l & c, grow pc */
3782                   qsort_swap(u_right, pc_left);
3783                   ++pc_right;
3784                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3785                } else {
3786                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3787                   qsort_rotate(u_right, pc_left, u_left);
3788                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3789                }
3790             } else if (s == 0) {
3791                /* l > c, c == r - swap ends, grow pc */
3792                qsort_swap(u_right, u_left);
3793                --pc_left;
3794                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3795             } else {
3796                /* l > c, c > r - swap ends to get in order */
3797                qsort_swap(u_right, u_left);
3798                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3799             }
3800          }
3801          /* We now know the 3 middle elements have been compared and
3802             arranged in the desired order, so we can shrink the uncompared
3803             sets on both sides
3804          */
3805          --u_right;
3806          ++u_left;
3807          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3808
3809          /* The above massive nested if was the simple part :-). We now have
3810             the middle 3 elements ordered and we need to scan through the
3811             uncompared sets on either side, swapping elements that are on
3812             the wrong side or simply shuffling equal elements around to get
3813             all equal elements into the pivot chunk.
3814          */
3815
3816          for ( ; ; ) {
3817             int still_work_on_left;
3818             int still_work_on_right;
3819
3820             /* Scan the uncompared values on the left. If I find a value
3821                equal to the pivot value, move it over so it is adjacent to
3822                the pivot chunk and expand the pivot chunk. If I find a value
3823                less than the pivot value, then just leave it - its already
3824                on the correct side of the partition. If I find a greater
3825                value, then stop the scan.
3826             */
3827             while (still_work_on_left = (u_right >= part_left)) {
3828                s = qsort_cmp(u_right, pc_left);
3829                if (s < 0) {
3830                   --u_right;
3831                } else if (s == 0) {
3832                   --pc_left;
3833                   if (pc_left != u_right) {
3834                      qsort_swap(u_right, pc_left);
3835                   }
3836                   --u_right;
3837                } else {
3838                   break;
3839                }
3840                qsort_assert(u_right < pc_left);
3841                qsort_assert(pc_left <= pc_right);
3842                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3843                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3844             }
3845
3846             /* Do a mirror image scan of uncompared values on the right
3847             */
3848             while (still_work_on_right = (u_left <= part_right)) {
3849                s = qsort_cmp(pc_right, u_left);
3850                if (s < 0) {
3851                   ++u_left;
3852                } else if (s == 0) {
3853                   ++pc_right;
3854                   if (pc_right != u_left) {
3855                      qsort_swap(pc_right, u_left);
3856                   }
3857                   ++u_left;
3858                } else {
3859                   break;
3860                }
3861                qsort_assert(u_left > pc_right);
3862                qsort_assert(pc_left <= pc_right);
3863                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3864                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3865             }
3866
3867             if (still_work_on_left) {
3868                /* I know I have a value on the left side which needs to be
3869                   on the right side, but I need to know more to decide
3870                   exactly the best thing to do with it.
3871                */
3872                if (still_work_on_right) {
3873                   /* I know I have values on both side which are out of
3874                      position. This is a big win because I kill two birds
3875                      with one swap (so to speak). I can advance the
3876                      uncompared pointers on both sides after swapping both
3877                      of them into the right place.
3878                   */
3879                   qsort_swap(u_right, u_left);
3880                   --u_right;
3881                   ++u_left;
3882                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3883                } else {
3884                   /* I have an out of position value on the left, but the
3885                      right is fully scanned, so I "slide" the pivot chunk
3886                      and any less-than values left one to make room for the
3887                      greater value over on the right. If the out of position
3888                      value is immediately adjacent to the pivot chunk (there
3889                      are no less-than values), I can do that with a swap,
3890                      otherwise, I have to rotate one of the less than values
3891                      into the former position of the out of position value
3892                      and the right end of the pivot chunk into the left end
3893                      (got all that?).
3894                   */
3895                   --pc_left;
3896                   if (pc_left == u_right) {
3897                      qsort_swap(u_right, pc_right);
3898                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3899                   } else {
3900                      qsort_rotate(u_right, pc_left, pc_right);
3901                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3902                   }
3903                   --pc_right;
3904                   --u_right;
3905                }
3906             } else if (still_work_on_right) {
3907                /* Mirror image of complex case above: I have an out of
3908                   position value on the right, but the left is fully
3909                   scanned, so I need to shuffle things around to make room
3910                   for the right value on the left.
3911                */
3912                ++pc_right;
3913                if (pc_right == u_left) {
3914                   qsort_swap(u_left, pc_left);
3915                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3916                } else {
3917                   qsort_rotate(pc_right, pc_left, u_left);
3918                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3919                }
3920                ++pc_left;
3921                ++u_left;
3922             } else {
3923                /* No more scanning required on either side of partition,
3924                   break out of loop and figure out next set of partitions
3925                */
3926                break;
3927             }
3928          }
3929
3930          /* The elements in the pivot chunk are now in the right place. They
3931             will never move or be compared again. All I have to do is decide
3932             what to do with the stuff to the left and right of the pivot
3933             chunk.
3934
3935             Notes on the QSORT_ORDER_GUESS ifdef code:
3936
3937             1. If I just built these partitions without swapping any (or
3938                very many) elements, there is a chance that the elements are
3939                already ordered properly (being properly ordered will
3940                certainly result in no swapping, but the converse can't be
3941                proved :-).
3942
3943             2. A (properly written) insertion sort will run faster on
3944                already ordered data than qsort will.
3945
3946             3. Perhaps there is some way to make a good guess about
3947                switching to an insertion sort earlier than partition size 6
3948                (for instance - we could save the partition size on the stack
3949                and increase the size each time we find we didn't swap, thus
3950                switching to insertion sort earlier for partitions with a
3951                history of not swapping).
3952
3953             4. Naturally, if I just switch right away, it will make
3954                artificial benchmarks with pure ascending (or descending)
3955                data look really good, but is that a good reason in general?
3956                Hard to say...
3957          */
3958
3959 #ifdef QSORT_ORDER_GUESS
3960          if (swapped < 3) {
3961 #if QSORT_ORDER_GUESS == 1
3962             qsort_break_even = (part_right - part_left) + 1;
3963 #endif
3964 #if QSORT_ORDER_GUESS == 2
3965             qsort_break_even *= 2;
3966 #endif
3967 #if QSORT_ORDER_GUESS == 3
3968             int prev_break = qsort_break_even;
3969             qsort_break_even *= qsort_break_even;
3970             if (qsort_break_even < prev_break) {
3971                qsort_break_even = (part_right - part_left) + 1;
3972             }
3973 #endif
3974          } else {
3975             qsort_break_even = QSORT_BREAK_EVEN;
3976          }
3977 #endif
3978
3979          if (part_left < pc_left) {
3980             /* There are elements on the left which need more processing.
3981                Check the right as well before deciding what to do.
3982             */
3983             if (pc_right < part_right) {
3984                /* We have two partitions to be sorted. Stack the biggest one
3985                   and process the smallest one on the next iteration. This
3986                   minimizes the stack height by insuring that any additional
3987                   stack entries must come from the smallest partition which
3988                   (because it is smallest) will have the fewest
3989                   opportunities to generate additional stack entries.
3990                */
3991                if ((part_right - pc_right) > (pc_left - part_left)) {
3992                   /* stack the right partition, process the left */
3993                   partition_stack[next_stack_entry].left = pc_right + 1;
3994                   partition_stack[next_stack_entry].right = part_right;
3995 #ifdef QSORT_ORDER_GUESS
3996                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3997 #endif
3998                   part_right = pc_left - 1;
3999                } else {
4000                   /* stack the left partition, process the right */
4001                   partition_stack[next_stack_entry].left = part_left;
4002                   partition_stack[next_stack_entry].right = pc_left - 1;
4003 #ifdef QSORT_ORDER_GUESS
4004                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4005 #endif
4006                   part_left = pc_right + 1;
4007                }
4008                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4009                ++next_stack_entry;
4010             } else {
4011                /* The elements on the left are the only remaining elements
4012                   that need sorting, arrange for them to be processed as the
4013                   next partition.
4014                */
4015                part_right = pc_left - 1;
4016             }
4017          } else if (pc_right < part_right) {
4018             /* There is only one chunk on the right to be sorted, make it
4019                the new partition and loop back around.
4020             */
4021             part_left = pc_right + 1;
4022          } else {
4023             /* This whole partition wound up in the pivot chunk, so
4024                we need to get a new partition off the stack.
4025             */
4026             if (next_stack_entry == 0) {
4027                /* the stack is empty - we are done */
4028                break;
4029             }
4030             --next_stack_entry;
4031             part_left = partition_stack[next_stack_entry].left;
4032             part_right = partition_stack[next_stack_entry].right;
4033 #ifdef QSORT_ORDER_GUESS
4034             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4035 #endif
4036          }
4037       } else {
4038          /* This partition is too small to fool with qsort complexity, just
4039             do an ordinary insertion sort to minimize overhead.
4040          */
4041          int i;
4042          /* Assume 1st element is in right place already, and start checking
4043             at 2nd element to see where it should be inserted.
4044          */
4045          for (i = part_left + 1; i <= part_right; ++i) {
4046             int j;
4047             /* Scan (backwards - just in case 'i' is already in right place)
4048                through the elements already sorted to see if the ith element
4049                belongs ahead of one of them.
4050             */
4051             for (j = i - 1; j >= part_left; --j) {
4052                if (qsort_cmp(i, j) >= 0) {
4053                   /* i belongs right after j
4054                   */
4055                   break;
4056                }
4057             }
4058             ++j;
4059             if (j != i) {
4060                /* Looks like we really need to move some things
4061                */
4062                int k;
4063                temp = array[i];
4064                for (k = i - 1; k >= j; --k)
4065                   array[k + 1] = array[k];
4066                array[j] = temp;
4067             }
4068          }
4069
4070          /* That partition is now sorted, grab the next one, or get out
4071             of the loop if there aren't any more.
4072          */
4073
4074          if (next_stack_entry == 0) {
4075             /* the stack is empty - we are done */
4076             break;
4077          }
4078          --next_stack_entry;
4079          part_left = partition_stack[next_stack_entry].left;
4080          part_right = partition_stack[next_stack_entry].right;
4081 #ifdef QSORT_ORDER_GUESS
4082          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4083 #endif
4084       }
4085    }
4086
4087    /* Believe it or not, the array is sorted at this point! */
4088 }
4089
4090
4091 #ifdef PERL_OBJECT
4092 #undef this
4093 #define this pPerl
4094 #include "XSUB.h"
4095 #endif
4096
4097
4098 static I32
4099 sortcv(pTHXo_ SV *a, SV *b)
4100 {
4101     dTHR;
4102     I32 oldsaveix = PL_savestack_ix;
4103     I32 oldscopeix = PL_scopestack_ix;
4104     I32 result;
4105     GvSV(PL_firstgv) = a;
4106     GvSV(PL_secondgv) = b;
4107     PL_stack_sp = PL_stack_base;
4108     PL_op = PL_sortcop;
4109     CALLRUNOPS(aTHX);
4110     if (PL_stack_sp != PL_stack_base + 1)
4111         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4112     if (!SvNIOKp(*PL_stack_sp))
4113         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4114     result = SvIV(*PL_stack_sp);
4115     while (PL_scopestack_ix > oldscopeix) {
4116         LEAVE;
4117     }
4118     leave_scope(oldsaveix);
4119     return result;
4120 }
4121
4122
4123 static I32
4124 sv_ncmp(pTHXo_ SV *a, SV *b)
4125 {
4126     NV nv1 = SvNV(a);
4127     NV nv2 = SvNV(b);
4128     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4129 }
4130
4131 static I32
4132 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4133 {
4134     IV iv1 = SvIV(a);
4135     IV iv2 = SvIV(b);
4136     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4137 }
4138 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4139           *svp = Nullsv;                                \
4140           if (PL_amagic_generation) { \
4141             if (SvAMAGIC(left)||SvAMAGIC(right))\
4142                 *svp = amagic_call(left, \
4143                                    right, \
4144                                    CAT2(meth,_amg), \
4145                                    0); \
4146           } \
4147         } STMT_END
4148
4149 static I32
4150 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4151 {
4152     SV *tmpsv;
4153     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4154     if (tmpsv) {
4155         NV d;
4156
4157         if (SvIOK(tmpsv)) {
4158             I32 i = SvIVX(tmpsv);
4159             if (i > 0)
4160                return 1;
4161             return i? -1 : 0;
4162         }
4163         d = SvNV(tmpsv);
4164         if (d > 0)
4165            return 1;
4166         return d? -1 : 0;
4167      }
4168      return sv_ncmp(aTHXo_ a, b);
4169 }
4170
4171 static I32
4172 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4173 {
4174     SV *tmpsv;
4175     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4176     if (tmpsv) {
4177         NV d;
4178
4179         if (SvIOK(tmpsv)) {
4180             I32 i = SvIVX(tmpsv);
4181             if (i > 0)
4182                return 1;
4183             return i? -1 : 0;
4184         }
4185         d = SvNV(tmpsv);
4186         if (d > 0)
4187            return 1;
4188         return d? -1 : 0;
4189     }
4190     return sv_i_ncmp(aTHXo_ a, b);
4191 }
4192
4193 static I32
4194 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4195 {
4196     SV *tmpsv;
4197     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4198     if (tmpsv) {
4199         NV d;
4200
4201         if (SvIOK(tmpsv)) {
4202             I32 i = SvIVX(tmpsv);
4203             if (i > 0)
4204                return 1;
4205             return i? -1 : 0;
4206         }
4207         d = SvNV(tmpsv);
4208         if (d > 0)
4209            return 1;
4210         return d? -1 : 0;
4211     }
4212     return sv_cmp(str1, str2);
4213 }
4214
4215 static I32
4216 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4217 {
4218     SV *tmpsv;
4219     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4220     if (tmpsv) {
4221         NV d;
4222
4223         if (SvIOK(tmpsv)) {
4224             I32 i = SvIVX(tmpsv);
4225             if (i > 0)
4226                return 1;
4227             return i? -1 : 0;
4228         }
4229         d = SvNV(tmpsv);
4230         if (d > 0)
4231            return 1;
4232         return d? -1 : 0;
4233     }
4234     return sv_cmp_locale(str1, str2);
4235 }
4236
4237 static I32
4238 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4239 {
4240     SV *datasv = FILTER_DATA(idx);
4241     int filter_has_file = IoLINES(datasv);
4242     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4243     SV *filter_state = (SV *)IoTOP_GV(datasv);
4244     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4245     int len = 0;
4246
4247     /* I was having segfault trouble under Linux 2.2.5 after a
4248        parse error occured.  (Had to hack around it with a test
4249        for PL_error_count == 0.)  Solaris doesn't segfault --
4250        not sure where the trouble is yet.  XXX */
4251
4252     if (filter_has_file) {
4253         len = FILTER_READ(idx+1, buf_sv, maxlen);
4254     }
4255
4256     if (filter_sub && len >= 0) {
4257         djSP;
4258         int count;
4259
4260         ENTER;
4261         SAVE_DEFSV;
4262         SAVETMPS;
4263         EXTEND(SP, 2);
4264
4265         DEFSV = buf_sv;
4266         PUSHMARK(SP);
4267         PUSHs(sv_2mortal(newSViv(maxlen)));
4268         if (filter_state) {
4269             PUSHs(filter_state);
4270         }
4271         PUTBACK;
4272         count = call_sv(filter_sub, G_SCALAR);
4273         SPAGAIN;
4274
4275         if (count > 0) {
4276             SV *out = POPs;
4277             if (SvOK(out)) {
4278                 len = SvIV(out);
4279             }
4280         }
4281
4282         PUTBACK;
4283         FREETMPS;
4284         LEAVE;
4285     }
4286
4287     if (len <= 0) {
4288         IoLINES(datasv) = 0;
4289         if (filter_child_proc) {
4290             SvREFCNT_dec(filter_child_proc);
4291             IoFMT_GV(datasv) = Nullgv;
4292         }
4293         if (filter_state) {
4294             SvREFCNT_dec(filter_state);
4295             IoTOP_GV(datasv) = Nullgv;
4296         }
4297         if (filter_sub) {
4298             SvREFCNT_dec(filter_sub);
4299             IoBOTTOM_GV(datasv) = Nullgv;
4300         }
4301         filter_del(run_user_filter);
4302     }
4303
4304     return len;
4305 }
4306
4307 #ifdef PERL_OBJECT
4308
4309 static I32
4310 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4311 {
4312     return sv_cmp_locale(str1, str2);
4313 }
4314
4315 static I32
4316 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4317 {
4318     return sv_cmp(str1, str2);
4319 }
4320
4321 #endif /* PERL_OBJECT */