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(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1449                               SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1450     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1451     if (!MAXARG)
1452         RETURN;
1453     if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1454         sv = NEWSV(49, 0);
1455         gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1456         PUSHs(sv_2mortal(sv));
1457         PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1458     }
1459     else {
1460         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1461         PUSHs(sv_2mortal(newSViv(0)));
1462     }
1463     gimme = (I32)cx->blk_gimme;
1464     if (gimme == G_VOID)
1465         PUSHs(&PL_sv_undef);
1466     else
1467         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1468     if (CxTYPE(cx) == CXt_EVAL) {
1469         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1470             PUSHs(cx->blk_eval.cur_text);
1471             PUSHs(&PL_sv_no);
1472         }
1473         else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1474             /* Require, put the name. */
1475             PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1476             PUSHs(&PL_sv_yes);
1477         }
1478     }
1479     else {
1480         PUSHs(&PL_sv_undef);
1481         PUSHs(&PL_sv_undef);
1482     }
1483     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1484         && PL_curcop->cop_stash == PL_debstash)
1485     {
1486         AV *ary = cx->blk_sub.argarray;
1487         int off = AvARRAY(ary) - AvALLOC(ary);
1488
1489         if (!PL_dbargs) {
1490             GV* tmpgv;
1491             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1492                                 SVt_PVAV)));
1493             GvMULTI_on(tmpgv);
1494             AvREAL_off(PL_dbargs);              /* XXX Should be REIFY */
1495         }
1496
1497         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1498             av_extend(PL_dbargs, AvFILLp(ary) + off);
1499         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1500         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1501     }
1502     /* XXX only hints propagated via op_private are currently
1503      * visible (others are not easily accessible, since they
1504      * use the global PL_hints) */
1505     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1506                              HINT_PRIVATE_MASK)));
1507     RETURN;
1508 }
1509
1510 PP(pp_reset)
1511 {
1512     djSP;
1513     char *tmps;
1514     STRLEN n_a;
1515
1516     if (MAXARG < 1)
1517         tmps = "";
1518     else
1519         tmps = POPpx;
1520     sv_reset(tmps, PL_curcop->cop_stash);
1521     PUSHs(&PL_sv_yes);
1522     RETURN;
1523 }
1524
1525 PP(pp_lineseq)
1526 {
1527     return NORMAL;
1528 }
1529
1530 PP(pp_dbstate)
1531 {
1532     PL_curcop = (COP*)PL_op;
1533     TAINT_NOT;          /* Each statement is presumed innocent */
1534     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1535     FREETMPS;
1536
1537     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1538     {
1539         djSP;
1540         register CV *cv;
1541         register PERL_CONTEXT *cx;
1542         I32 gimme = G_ARRAY;
1543         I32 hasargs;
1544         GV *gv;
1545
1546         gv = PL_DBgv;
1547         cv = GvCV(gv);
1548         if (!cv)
1549             DIE(aTHX_ "No DB::DB routine defined");
1550
1551         if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1552             return NORMAL;
1553
1554         ENTER;
1555         SAVETMPS;
1556
1557         SAVEI32(PL_debug);
1558         SAVESTACK_POS();
1559         PL_debug = 0;
1560         hasargs = 0;
1561         SPAGAIN;
1562
1563         push_return(PL_op->op_next);
1564         PUSHBLOCK(cx, CXt_SUB, SP);
1565         PUSHSUB(cx);
1566         CvDEPTH(cv)++;
1567         (void)SvREFCNT_inc(cv);
1568         SAVESPTR(PL_curpad);
1569         PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1570         RETURNOP(CvSTART(cv));
1571     }
1572     else
1573         return NORMAL;
1574 }
1575
1576 PP(pp_scope)
1577 {
1578     return NORMAL;
1579 }
1580
1581 PP(pp_enteriter)
1582 {
1583     djSP; dMARK;
1584     register PERL_CONTEXT *cx;
1585     I32 gimme = GIMME_V;
1586     SV **svp;
1587
1588     ENTER;
1589     SAVETMPS;
1590
1591 #ifdef USE_THREADS
1592     if (PL_op->op_flags & OPf_SPECIAL) {
1593         dTHR;
1594         svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
1595         SAVEGENERICSV(*svp);
1596         *svp = NEWSV(0,0);
1597     }
1598     else
1599 #endif /* USE_THREADS */
1600     if (PL_op->op_targ) {
1601         svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1602         SAVESPTR(*svp);
1603     }
1604     else {
1605         svp = &GvSV((GV*)POPs);                 /* symbol table variable */
1606         SAVEGENERICSV(*svp);
1607         *svp = NEWSV(0,0);
1608     }
1609
1610     ENTER;
1611
1612     PUSHBLOCK(cx, CXt_LOOP, SP);
1613     PUSHLOOP(cx, svp, MARK);
1614     if (PL_op->op_flags & OPf_STACKED) {
1615         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1616         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1617             dPOPss;
1618             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1619                 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1620                  if (SvNV(sv) < IV_MIN ||
1621                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1622                      DIE(aTHX_ "Range iterator outside integer range");
1623                  cx->blk_loop.iterix = SvIV(sv);
1624                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1625             }
1626             else
1627                 cx->blk_loop.iterlval = newSVsv(sv);
1628         }
1629     }
1630     else {
1631         cx->blk_loop.iterary = PL_curstack;
1632         AvFILLp(PL_curstack) = SP - PL_stack_base;
1633         cx->blk_loop.iterix = MARK - PL_stack_base;
1634     }
1635
1636     RETURN;
1637 }
1638
1639 PP(pp_enterloop)
1640 {
1641     djSP;
1642     register PERL_CONTEXT *cx;
1643     I32 gimme = GIMME_V;
1644
1645     ENTER;
1646     SAVETMPS;
1647     ENTER;
1648
1649     PUSHBLOCK(cx, CXt_LOOP, SP);
1650     PUSHLOOP(cx, 0, SP);
1651
1652     RETURN;
1653 }
1654
1655 PP(pp_leaveloop)
1656 {
1657     djSP;
1658     register PERL_CONTEXT *cx;
1659     I32 gimme;
1660     SV **newsp;
1661     PMOP *newpm;
1662     SV **mark;
1663
1664     POPBLOCK(cx,newpm);
1665     mark = newsp;
1666     newsp = PL_stack_base + cx->blk_loop.resetsp;
1667
1668     TAINT_NOT;
1669     if (gimme == G_VOID)
1670         ; /* do nothing */
1671     else if (gimme == G_SCALAR) {
1672         if (mark < SP)
1673             *++newsp = sv_mortalcopy(*SP);
1674         else
1675             *++newsp = &PL_sv_undef;
1676     }
1677     else {
1678         while (mark < SP) {
1679             *++newsp = sv_mortalcopy(*++mark);
1680             TAINT_NOT;          /* Each item is independent */
1681         }
1682     }
1683     SP = newsp;
1684     PUTBACK;
1685
1686     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1687     PL_curpm = newpm;   /* ... and pop $1 et al */
1688
1689     LEAVE;
1690     LEAVE;
1691
1692     return NORMAL;
1693 }
1694
1695 PP(pp_return)
1696 {
1697     djSP; dMARK;
1698     I32 cxix;
1699     register PERL_CONTEXT *cx;
1700     bool popsub2 = FALSE;
1701     I32 gimme;
1702     SV **newsp;
1703     PMOP *newpm;
1704     I32 optype = 0;
1705     SV *sv;
1706
1707     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1708         if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1709             if (cxstack_ix > PL_sortcxix)
1710                 dounwind(PL_sortcxix);
1711             AvARRAY(PL_curstack)[1] = *SP;
1712             PL_stack_sp = PL_stack_base + 1;
1713             return 0;
1714         }
1715     }
1716
1717     cxix = dopoptosub(cxstack_ix);
1718     if (cxix < 0)
1719         DIE(aTHX_ "Can't return outside a subroutine");
1720     if (cxix < cxstack_ix)
1721         dounwind(cxix);
1722
1723     POPBLOCK(cx,newpm);
1724     switch (CxTYPE(cx)) {
1725     case CXt_SUB:
1726         popsub2 = TRUE;
1727         break;
1728     case CXt_EVAL:
1729         POPEVAL(cx);
1730         if (AvFILLp(PL_comppad_name) >= 0)
1731             free_closures();
1732         lex_end();
1733         if (optype == OP_REQUIRE &&
1734             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1735         {
1736             /* Unassume the success we assumed earlier. */
1737             char *name = cx->blk_eval.old_name;
1738             (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1739             DIE(aTHX_ "%s did not return a true value", name);
1740         }
1741         break;
1742     default:
1743         DIE(aTHX_ "panic: return");
1744     }
1745
1746     TAINT_NOT;
1747     if (gimme == G_SCALAR) {
1748         if (MARK < SP) {
1749             if (popsub2) {
1750                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1751                     if (SvTEMP(TOPs)) {
1752                         *++newsp = SvREFCNT_inc(*SP);
1753                         FREETMPS;
1754                         sv_2mortal(*newsp);
1755                     } else {
1756                         FREETMPS;
1757                         *++newsp = sv_mortalcopy(*SP);
1758                     }
1759                 } else
1760                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1761             } else
1762                 *++newsp = sv_mortalcopy(*SP);
1763         } else
1764             *++newsp = &PL_sv_undef;
1765     }
1766     else if (gimme == G_ARRAY) {
1767         while (++MARK <= SP) {
1768             *++newsp = (popsub2 && SvTEMP(*MARK))
1769                         ? *MARK : sv_mortalcopy(*MARK);
1770             TAINT_NOT;          /* Each item is independent */
1771         }
1772     }
1773     PL_stack_sp = newsp;
1774
1775     /* Stack values are safe: */
1776     if (popsub2) {
1777         POPSUB(cx,sv);  /* release CV and @_ ... */
1778     }
1779     else
1780         sv = Nullsv;
1781     PL_curpm = newpm;   /* ... and pop $1 et al */
1782
1783     LEAVE;
1784     LEAVESUB(sv);
1785     return pop_return();
1786 }
1787
1788 PP(pp_last)
1789 {
1790     djSP;
1791     I32 cxix;
1792     register PERL_CONTEXT *cx;
1793     I32 pop2 = 0;
1794     I32 gimme;
1795     I32 optype;
1796     OP *nextop;
1797     SV **newsp;
1798     PMOP *newpm;
1799     SV **mark;
1800     SV *sv = Nullsv;
1801
1802     if (PL_op->op_flags & OPf_SPECIAL) {
1803         cxix = dopoptoloop(cxstack_ix);
1804         if (cxix < 0)
1805             DIE(aTHX_ "Can't \"last\" outside a block");
1806     }
1807     else {
1808         cxix = dopoptolabel(cPVOP->op_pv);
1809         if (cxix < 0)
1810             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1811     }
1812     if (cxix < cxstack_ix)
1813         dounwind(cxix);
1814
1815     POPBLOCK(cx,newpm);
1816     mark = newsp;
1817     switch (CxTYPE(cx)) {
1818     case CXt_LOOP:
1819         pop2 = CXt_LOOP;
1820         newsp = PL_stack_base + cx->blk_loop.resetsp;
1821         nextop = cx->blk_loop.last_op->op_next;
1822         break;
1823     case CXt_SUB:
1824         pop2 = CXt_SUB;
1825         nextop = pop_return();
1826         break;
1827     case CXt_EVAL:
1828         POPEVAL(cx);
1829         nextop = pop_return();
1830         break;
1831     default:
1832         DIE(aTHX_ "panic: last");
1833     }
1834
1835     TAINT_NOT;
1836     if (gimme == G_SCALAR) {
1837         if (MARK < SP)
1838             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1839                         ? *SP : sv_mortalcopy(*SP);
1840         else
1841             *++newsp = &PL_sv_undef;
1842     }
1843     else if (gimme == G_ARRAY) {
1844         while (++MARK <= SP) {
1845             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1846                         ? *MARK : sv_mortalcopy(*MARK);
1847             TAINT_NOT;          /* Each item is independent */
1848         }
1849     }
1850     SP = newsp;
1851     PUTBACK;
1852
1853     /* Stack values are safe: */
1854     switch (pop2) {
1855     case CXt_LOOP:
1856         POPLOOP(cx);    /* release loop vars ... */
1857         LEAVE;
1858         break;
1859     case CXt_SUB:
1860         POPSUB(cx,sv);  /* release CV and @_ ... */
1861         break;
1862     }
1863     PL_curpm = newpm;   /* ... and pop $1 et al */
1864
1865     LEAVE;
1866     LEAVESUB(sv);
1867     return nextop;
1868 }
1869
1870 PP(pp_next)
1871 {
1872     I32 cxix;
1873     register PERL_CONTEXT *cx;
1874     I32 oldsave;
1875
1876     if (PL_op->op_flags & OPf_SPECIAL) {
1877         cxix = dopoptoloop(cxstack_ix);
1878         if (cxix < 0)
1879             DIE(aTHX_ "Can't \"next\" outside a block");
1880     }
1881     else {
1882         cxix = dopoptolabel(cPVOP->op_pv);
1883         if (cxix < 0)
1884             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1885     }
1886     if (cxix < cxstack_ix)
1887         dounwind(cxix);
1888
1889     TOPBLOCK(cx);
1890     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1891     LEAVE_SCOPE(oldsave);
1892     return cx->blk_loop.next_op;
1893 }
1894
1895 PP(pp_redo)
1896 {
1897     I32 cxix;
1898     register PERL_CONTEXT *cx;
1899     I32 oldsave;
1900
1901     if (PL_op->op_flags & OPf_SPECIAL) {
1902         cxix = dopoptoloop(cxstack_ix);
1903         if (cxix < 0)
1904             DIE(aTHX_ "Can't \"redo\" outside a block");
1905     }
1906     else {
1907         cxix = dopoptolabel(cPVOP->op_pv);
1908         if (cxix < 0)
1909             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1910     }
1911     if (cxix < cxstack_ix)
1912         dounwind(cxix);
1913
1914     TOPBLOCK(cx);
1915     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1916     LEAVE_SCOPE(oldsave);
1917     return cx->blk_loop.redo_op;
1918 }
1919
1920 STATIC OP *
1921 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1922 {
1923     OP *kid;
1924     OP **ops = opstack;
1925     static char too_deep[] = "Target of goto is too deeply nested";
1926
1927     if (ops >= oplimit)
1928         Perl_croak(aTHX_ too_deep);
1929     if (o->op_type == OP_LEAVE ||
1930         o->op_type == OP_SCOPE ||
1931         o->op_type == OP_LEAVELOOP ||
1932         o->op_type == OP_LEAVETRY)
1933     {
1934         *ops++ = cUNOPo->op_first;
1935         if (ops >= oplimit)
1936             Perl_croak(aTHX_ too_deep);
1937     }
1938     *ops = 0;
1939     if (o->op_flags & OPf_KIDS) {
1940         dTHR;
1941         /* First try all the kids at this level, since that's likeliest. */
1942         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1943             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1944                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
1945                 return kid;
1946         }
1947         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1948             if (kid == PL_lastgotoprobe)
1949                 continue;
1950             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1951                 (ops == opstack ||
1952                  (ops[-1]->op_type != OP_NEXTSTATE &&
1953                   ops[-1]->op_type != OP_DBSTATE)))
1954                 *ops++ = kid;
1955             if (o = dofindlabel(kid, label, ops, oplimit))
1956                 return o;
1957         }
1958     }
1959     *ops = 0;
1960     return 0;
1961 }
1962
1963 PP(pp_dump)
1964 {
1965     return pp_goto();
1966     /*NOTREACHED*/
1967 }
1968
1969 PP(pp_goto)
1970 {
1971     djSP;
1972     OP *retop = 0;
1973     I32 ix;
1974     register PERL_CONTEXT *cx;
1975 #define GOTO_DEPTH 64
1976     OP *enterops[GOTO_DEPTH];
1977     char *label;
1978     int do_dump = (PL_op->op_type == OP_DUMP);
1979     static char must_have_label[] = "goto must have label";
1980
1981     label = 0;
1982     if (PL_op->op_flags & OPf_STACKED) {
1983         SV *sv = POPs;
1984         STRLEN n_a;
1985
1986         /* This egregious kludge implements goto &subroutine */
1987         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1988             I32 cxix;
1989             register PERL_CONTEXT *cx;
1990             CV* cv = (CV*)SvRV(sv);
1991             SV** mark;
1992             I32 items = 0;
1993             I32 oldsave;
1994
1995         retry:
1996             if (!CvROOT(cv) && !CvXSUB(cv)) {
1997                 GV *gv = CvGV(cv);
1998                 GV *autogv;
1999                 if (gv) {
2000                     SV *tmpstr;
2001                     /* autoloaded stub? */
2002                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2003                         goto retry;
2004                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2005                                           GvNAMELEN(gv), FALSE);
2006                     if (autogv && (cv = GvCV(autogv)))
2007                         goto retry;
2008                     tmpstr = sv_newmortal();
2009                     gv_efullname3(tmpstr, gv, Nullch);
2010                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2011                 }
2012                 DIE(aTHX_ "Goto undefined subroutine");
2013             }
2014
2015             /* First do some returnish stuff. */
2016             cxix = dopoptosub(cxstack_ix);
2017             if (cxix < 0)
2018                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2019             if (cxix < cxstack_ix)
2020                 dounwind(cxix);
2021             TOPBLOCK(cx);
2022             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2023                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2024             mark = PL_stack_sp;
2025             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2026                 /* put @_ back onto stack */
2027                 AV* av = cx->blk_sub.argarray;
2028
2029                 items = AvFILLp(av) + 1;
2030                 PL_stack_sp++;
2031                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2032                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2033                 PL_stack_sp += items;
2034 #ifndef USE_THREADS
2035                 SvREFCNT_dec(GvAV(PL_defgv));
2036                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2037 #endif /* USE_THREADS */
2038                 /* abandon @_ if it got reified */
2039                 if (AvREAL(av)) {
2040                     (void)sv_2mortal((SV*)av);  /* delay until return */
2041                     av = newAV();
2042                     av_extend(av, items-1);
2043                     AvFLAGS(av) = AVf_REIFY;
2044                     PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2045                 }
2046             }
2047             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2048                 AV* av;
2049                 int i;
2050 #ifdef USE_THREADS
2051                 av = (AV*)PL_curpad[0];
2052 #else
2053                 av = GvAV(PL_defgv);
2054 #endif
2055                 items = AvFILLp(av) + 1;
2056                 PL_stack_sp++;
2057                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2058                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2059                 PL_stack_sp += items;
2060             }
2061             if (CxTYPE(cx) == CXt_SUB &&
2062                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2063                 SvREFCNT_dec(cx->blk_sub.cv);
2064             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2065             LEAVE_SCOPE(oldsave);
2066
2067             /* Now do some callish stuff. */
2068             SAVETMPS;
2069             if (CvXSUB(cv)) {
2070 #ifdef PERL_XSUB_OLDSTYLE
2071                 if (CvOLDSTYLE(cv)) {
2072                     I32 (*fp3)(int,int,int);
2073                     while (SP > mark) {
2074                         SP[1] = SP[0];
2075                         SP--;
2076                     }
2077                     fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
2078                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2079                                    mark - PL_stack_base + 1,
2080                                    items);
2081                     SP = PL_stack_base + items;
2082                 }
2083                 else
2084 #endif /* PERL_XSUB_OLDSTYLE */
2085                 {
2086                     SV **newsp;
2087                     I32 gimme;
2088
2089                     PL_stack_sp--;              /* There is no cv arg. */
2090                     /* Push a mark for the start of arglist */
2091                     PUSHMARK(mark);
2092                     (void)(*CvXSUB(cv))(aTHXo_ cv);
2093                     /* Pop the current context like a decent sub should */
2094                     POPBLOCK(cx, PL_curpm);
2095                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2096                 }
2097                 LEAVE;
2098                 return pop_return();
2099             }
2100             else {
2101                 AV* padlist = CvPADLIST(cv);
2102                 SV** svp = AvARRAY(padlist);
2103                 if (CxTYPE(cx) == CXt_EVAL) {
2104                     PL_in_eval = cx->blk_eval.old_in_eval;
2105                     PL_eval_root = cx->blk_eval.old_eval_root;
2106                     cx->cx_type = CXt_SUB;
2107                     cx->blk_sub.hasargs = 0;
2108                 }
2109                 cx->blk_sub.cv = cv;
2110                 cx->blk_sub.olddepth = CvDEPTH(cv);
2111                 CvDEPTH(cv)++;
2112                 if (CvDEPTH(cv) < 2)
2113                     (void)SvREFCNT_inc(cv);
2114                 else {  /* save temporaries on recursion? */
2115                     PERL_STACK_OVERFLOW_CHECK();
2116                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2117                         sub_crush_depth(cv);
2118                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2119                         AV *newpad = newAV();
2120                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2121                         I32 ix = AvFILLp((AV*)svp[1]);
2122                         svp = AvARRAY(svp[0]);
2123                         for ( ;ix > 0; ix--) {
2124                             if (svp[ix] != &PL_sv_undef) {
2125                                 char *name = SvPVX(svp[ix]);
2126                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2127                                     || *name == '&')
2128                                 {
2129                                     /* outer lexical or anon code */
2130                                     av_store(newpad, ix,
2131                                         SvREFCNT_inc(oldpad[ix]) );
2132                                 }
2133                                 else {          /* our own lexical */
2134                                     if (*name == '@')
2135                                         av_store(newpad, ix, sv = (SV*)newAV());
2136                                     else if (*name == '%')
2137                                         av_store(newpad, ix, sv = (SV*)newHV());
2138                                     else
2139                                         av_store(newpad, ix, sv = NEWSV(0,0));
2140                                     SvPADMY_on(sv);
2141                                 }
2142                             }
2143                             else {
2144                                 av_store(newpad, ix, sv = NEWSV(0,0));
2145                                 SvPADTMP_on(sv);
2146                             }
2147                         }
2148                         if (cx->blk_sub.hasargs) {
2149                             AV* av = newAV();
2150                             av_extend(av, 0);
2151                             av_store(newpad, 0, (SV*)av);
2152                             AvFLAGS(av) = AVf_REIFY;
2153                         }
2154                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2155                         AvFILLp(padlist) = CvDEPTH(cv);
2156                         svp = AvARRAY(padlist);
2157                     }
2158                 }
2159 #ifdef USE_THREADS
2160                 if (!cx->blk_sub.hasargs) {
2161                     AV* av = (AV*)PL_curpad[0];
2162
2163                     items = AvFILLp(av) + 1;
2164                     if (items) {
2165                         /* Mark is at the end of the stack. */
2166                         EXTEND(SP, items);
2167                         Copy(AvARRAY(av), SP + 1, items, SV*);
2168                         SP += items;
2169                         PUTBACK ;
2170                     }
2171                 }
2172 #endif /* USE_THREADS */
2173                 SAVESPTR(PL_curpad);
2174                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2175 #ifndef USE_THREADS
2176                 if (cx->blk_sub.hasargs)
2177 #endif /* USE_THREADS */
2178                 {
2179                     AV* av = (AV*)PL_curpad[0];
2180                     SV** ary;
2181
2182 #ifndef USE_THREADS
2183                     cx->blk_sub.savearray = GvAV(PL_defgv);
2184                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2185 #endif /* USE_THREADS */
2186                     cx->blk_sub.argarray = av;
2187                     ++mark;
2188
2189                     if (items >= AvMAX(av) + 1) {
2190                         ary = AvALLOC(av);
2191                         if (AvARRAY(av) != ary) {
2192                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2193                             SvPVX(av) = (char*)ary;
2194                         }
2195                         if (items >= AvMAX(av) + 1) {
2196                             AvMAX(av) = items - 1;
2197                             Renew(ary,items+1,SV*);
2198                             AvALLOC(av) = ary;
2199                             SvPVX(av) = (char*)ary;
2200                         }
2201                     }
2202                     Copy(mark,AvARRAY(av),items,SV*);
2203                     AvFILLp(av) = items - 1;
2204                     assert(!AvREAL(av));
2205                     while (items--) {
2206                         if (*mark)
2207                             SvTEMP_off(*mark);
2208                         mark++;
2209                     }
2210                 }
2211                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2212                     /*
2213                      * We do not care about using sv to call CV;
2214                      * it's for informational purposes only.
2215                      */
2216                     SV *sv = GvSV(PL_DBsub);
2217                     CV *gotocv;
2218
2219                     if (PERLDB_SUB_NN) {
2220                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2221                     } else {
2222                         save_item(sv);
2223                         gv_efullname3(sv, CvGV(cv), Nullch);
2224                     }
2225                     if (  PERLDB_GOTO
2226                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2227                         PUSHMARK( PL_stack_sp );
2228                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2229                         PL_stack_sp--;
2230                     }
2231                 }
2232                 RETURNOP(CvSTART(cv));
2233             }
2234         }
2235         else {
2236             label = SvPV(sv,n_a);
2237             if (!(do_dump || *label))
2238                 DIE(aTHX_ must_have_label);
2239         }
2240     }
2241     else if (PL_op->op_flags & OPf_SPECIAL) {
2242         if (! do_dump)
2243             DIE(aTHX_ must_have_label);
2244     }
2245     else
2246         label = cPVOP->op_pv;
2247
2248     if (label && *label) {
2249         OP *gotoprobe = 0;
2250
2251         /* find label */
2252
2253         PL_lastgotoprobe = 0;
2254         *enterops = 0;
2255         for (ix = cxstack_ix; ix >= 0; ix--) {
2256             cx = &cxstack[ix];
2257             switch (CxTYPE(cx)) {
2258             case CXt_EVAL:
2259                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2260                 break;
2261             case CXt_LOOP:
2262                 gotoprobe = cx->blk_oldcop->op_sibling;
2263                 break;
2264             case CXt_SUBST:
2265                 continue;
2266             case CXt_BLOCK:
2267                 if (ix)
2268                     gotoprobe = cx->blk_oldcop->op_sibling;
2269                 else
2270                     gotoprobe = PL_main_root;
2271                 break;
2272             case CXt_SUB:
2273                 if (CvDEPTH(cx->blk_sub.cv)) {
2274                     gotoprobe = CvROOT(cx->blk_sub.cv);
2275                     break;
2276                 }
2277                 /* FALL THROUGH */
2278             case CXt_NULL:
2279                 DIE(aTHX_ "Can't \"goto\" outside a block");
2280             default:
2281                 if (ix)
2282                     DIE(aTHX_ "panic: goto");
2283                 gotoprobe = PL_main_root;
2284                 break;
2285             }
2286             retop = dofindlabel(gotoprobe, label,
2287                                 enterops, enterops + GOTO_DEPTH);
2288             if (retop)
2289                 break;
2290             PL_lastgotoprobe = gotoprobe;
2291         }
2292         if (!retop)
2293             DIE(aTHX_ "Can't find label %s", label);
2294
2295         /* pop unwanted frames */
2296
2297         if (ix < cxstack_ix) {
2298             I32 oldsave;
2299
2300             if (ix < 0)
2301                 ix = 0;
2302             dounwind(ix);
2303             TOPBLOCK(cx);
2304             oldsave = PL_scopestack[PL_scopestack_ix];
2305             LEAVE_SCOPE(oldsave);
2306         }
2307
2308         /* push wanted frames */
2309
2310         if (*enterops && enterops[1]) {
2311             OP *oldop = PL_op;
2312             for (ix = 1; enterops[ix]; ix++) {
2313                 PL_op = enterops[ix];
2314                 /* Eventually we may want to stack the needed arguments
2315                  * for each op.  For now, we punt on the hard ones. */
2316                 if (PL_op->op_type == OP_ENTERITER)
2317                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2318                         label);
2319                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2320             }
2321             PL_op = oldop;
2322         }
2323     }
2324
2325     if (do_dump) {
2326 #ifdef VMS
2327         if (!retop) retop = PL_main_start;
2328 #endif
2329         PL_restartop = retop;
2330         PL_do_undump = TRUE;
2331
2332         my_unexec();
2333
2334         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2335         PL_do_undump = FALSE;
2336     }
2337
2338     RETURNOP(retop);
2339 }
2340
2341 PP(pp_exit)
2342 {
2343     djSP;
2344     I32 anum;
2345
2346     if (MAXARG < 1)
2347         anum = 0;
2348     else {
2349         anum = SvIVx(POPs);
2350 #ifdef VMSISH_EXIT
2351         if (anum == 1 && VMSISH_EXIT)
2352             anum = 0;
2353 #endif
2354     }
2355     my_exit(anum);
2356     PUSHs(&PL_sv_undef);
2357     RETURN;
2358 }
2359
2360 #ifdef NOTYET
2361 PP(pp_nswitch)
2362 {
2363     djSP;
2364     NV value = SvNVx(GvSV(cCOP->cop_gv));
2365     register I32 match = I_32(value);
2366
2367     if (value < 0.0) {
2368         if (((NV)match) > value)
2369             --match;            /* was fractional--truncate other way */
2370     }
2371     match -= cCOP->uop.scop.scop_offset;
2372     if (match < 0)
2373         match = 0;
2374     else if (match > cCOP->uop.scop.scop_max)
2375         match = cCOP->uop.scop.scop_max;
2376     PL_op = cCOP->uop.scop.scop_next[match];
2377     RETURNOP(PL_op);
2378 }
2379
2380 PP(pp_cswitch)
2381 {
2382     djSP;
2383     register I32 match;
2384
2385     if (PL_multiline)
2386         PL_op = PL_op->op_next;                 /* can't assume anything */
2387     else {
2388         STRLEN n_a;
2389         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2390         match -= cCOP->uop.scop.scop_offset;
2391         if (match < 0)
2392             match = 0;
2393         else if (match > cCOP->uop.scop.scop_max)
2394             match = cCOP->uop.scop.scop_max;
2395         PL_op = cCOP->uop.scop.scop_next[match];
2396     }
2397     RETURNOP(PL_op);
2398 }
2399 #endif
2400
2401 /* Eval. */
2402
2403 STATIC void
2404 S_save_lines(pTHX_ AV *array, SV *sv)
2405 {
2406     register char *s = SvPVX(sv);
2407     register char *send = SvPVX(sv) + SvCUR(sv);
2408     register char *t;
2409     register I32 line = 1;
2410
2411     while (s && s < send) {
2412         SV *tmpstr = NEWSV(85,0);
2413
2414         sv_upgrade(tmpstr, SVt_PVMG);
2415         t = strchr(s, '\n');
2416         if (t)
2417             t++;
2418         else
2419             t = send;
2420
2421         sv_setpvn(tmpstr, s, t - s);
2422         av_store(array, line++, tmpstr);
2423         s = t;
2424     }
2425 }
2426
2427 STATIC void *
2428 S_docatch_body(pTHX_ va_list args)
2429 {
2430     CALLRUNOPS(aTHX);
2431     return NULL;
2432 }
2433
2434 STATIC OP *
2435 S_docatch(pTHX_ OP *o)
2436 {
2437     dTHR;
2438     int ret;
2439     OP *oldop = PL_op;
2440     volatile PERL_SI *cursi = PL_curstackinfo;
2441     dJMPENV;
2442
2443 #ifdef DEBUGGING
2444     assert(CATCH_GET == TRUE);
2445 #endif
2446     PL_op = o;
2447  redo_body:
2448     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2449     switch (ret) {
2450     case 0:
2451         break;
2452     case 3:
2453         if (PL_restartop && cursi == PL_curstackinfo) {
2454             PL_op = PL_restartop;
2455             PL_restartop = 0;
2456             goto redo_body;
2457         }
2458         /* FALL THROUGH */
2459     default:
2460         PL_op = oldop;
2461         JMPENV_JUMP(ret);
2462         /* NOTREACHED */
2463     }
2464     PL_op = oldop;
2465     return Nullop;
2466 }
2467
2468 OP *
2469 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2470 /* sv Text to convert to OP tree. */
2471 /* startop op_free() this to undo. */
2472 /* code Short string id of the caller. */
2473 {
2474     dSP;                                /* Make POPBLOCK work. */
2475     PERL_CONTEXT *cx;
2476     SV **newsp;
2477     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2478     I32 optype;
2479     OP dummy;
2480     OP *oop = PL_op, *rop;
2481     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2482     char *safestr;
2483
2484     ENTER;
2485     lex_start(sv);
2486     SAVETMPS;
2487     /* switch to eval mode */
2488
2489     if (PL_curcop == &PL_compiling) {
2490         SAVESPTR(PL_compiling.cop_stash);
2491         PL_compiling.cop_stash = PL_curstash;
2492     }
2493     SAVESPTR(PL_compiling.cop_filegv);
2494     SAVEI16(PL_compiling.cop_line);
2495     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2496     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2497     PL_compiling.cop_line = 1;
2498     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2499        deleting the eval's FILEGV from the stash before gv_check() runs
2500        (i.e. before run-time proper). To work around the coredump that
2501        ensues, we always turn GvMULTI_on for any globals that were
2502        introduced within evals. See force_ident(). GSAR 96-10-12 */
2503     safestr = savepv(tmpbuf);
2504     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2505     SAVEHINTS();
2506 #ifdef OP_IN_REGISTER
2507     PL_opsave = op;
2508 #else
2509     SAVEPPTR(PL_op);
2510 #endif
2511     PL_hints = 0;
2512
2513     PL_op = &dummy;
2514     PL_op->op_type = OP_ENTEREVAL;
2515     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2516     PUSHBLOCK(cx, CXt_EVAL, SP);
2517     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2518     rop = doeval(G_SCALAR, startop);
2519     POPBLOCK(cx,PL_curpm);
2520     POPEVAL(cx);
2521
2522     (*startop)->op_type = OP_NULL;
2523     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2524     lex_end();
2525     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2526     LEAVE;
2527     if (PL_curcop == &PL_compiling)
2528         PL_compiling.op_private = PL_hints;
2529 #ifdef OP_IN_REGISTER
2530     op = PL_opsave;
2531 #endif
2532     return rop;
2533 }
2534
2535 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2536 STATIC OP *
2537 S_doeval(pTHX_ int gimme, OP** startop)
2538 {
2539     dSP;
2540     OP *saveop = PL_op;
2541     HV *newstash;
2542     CV *caller;
2543     AV* comppadlist;
2544     I32 i;
2545
2546     PL_in_eval = EVAL_INEVAL;
2547
2548     PUSHMARK(SP);
2549
2550     /* set up a scratch pad */
2551
2552     SAVEI32(PL_padix);
2553     SAVESPTR(PL_curpad);
2554     SAVESPTR(PL_comppad);
2555     SAVESPTR(PL_comppad_name);
2556     SAVEI32(PL_comppad_name_fill);
2557     SAVEI32(PL_min_intro_pending);
2558     SAVEI32(PL_max_intro_pending);
2559
2560     caller = PL_compcv;
2561     for (i = cxstack_ix - 1; i >= 0; i--) {
2562         PERL_CONTEXT *cx = &cxstack[i];
2563         if (CxTYPE(cx) == CXt_EVAL)
2564             break;
2565         else if (CxTYPE(cx) == CXt_SUB) {
2566             caller = cx->blk_sub.cv;
2567             break;
2568         }
2569     }
2570
2571     SAVESPTR(PL_compcv);
2572     PL_compcv = (CV*)NEWSV(1104,0);
2573     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2574     CvEVAL_on(PL_compcv);
2575 #ifdef USE_THREADS
2576     CvOWNER(PL_compcv) = 0;
2577     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2578     MUTEX_INIT(CvMUTEXP(PL_compcv));
2579 #endif /* USE_THREADS */
2580
2581     PL_comppad = newAV();
2582     av_push(PL_comppad, Nullsv);
2583     PL_curpad = AvARRAY(PL_comppad);
2584     PL_comppad_name = newAV();
2585     PL_comppad_name_fill = 0;
2586     PL_min_intro_pending = 0;
2587     PL_padix = 0;
2588 #ifdef USE_THREADS
2589     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2590     PL_curpad[0] = (SV*)newAV();
2591     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2592 #endif /* USE_THREADS */
2593
2594     comppadlist = newAV();
2595     AvREAL_off(comppadlist);
2596     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2597     av_store(comppadlist, 1, (SV*)PL_comppad);
2598     CvPADLIST(PL_compcv) = comppadlist;
2599
2600     if (!saveop || saveop->op_type != OP_REQUIRE)
2601         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2602
2603     SAVEFREESV(PL_compcv);
2604
2605     /* make sure we compile in the right package */
2606
2607     newstash = PL_curcop->cop_stash;
2608     if (PL_curstash != newstash) {
2609         SAVESPTR(PL_curstash);
2610         PL_curstash = newstash;
2611     }
2612     SAVESPTR(PL_beginav);
2613     PL_beginav = newAV();
2614     SAVEFREESV(PL_beginav);
2615
2616     /* try to compile it */
2617
2618     PL_eval_root = Nullop;
2619     PL_error_count = 0;
2620     PL_curcop = &PL_compiling;
2621     PL_curcop->cop_arybase = 0;
2622     SvREFCNT_dec(PL_rs);
2623     PL_rs = newSVpvn("\n", 1);
2624     if (saveop && saveop->op_flags & OPf_SPECIAL)
2625         PL_in_eval |= EVAL_KEEPERR;
2626     else
2627         sv_setpv(ERRSV,"");
2628     if (yyparse() || PL_error_count || !PL_eval_root) {
2629         SV **newsp;
2630         I32 gimme;
2631         PERL_CONTEXT *cx;
2632         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2633         STRLEN n_a;
2634
2635         PL_op = saveop;
2636         if (PL_eval_root) {
2637             op_free(PL_eval_root);
2638             PL_eval_root = Nullop;
2639         }
2640         SP = PL_stack_base + POPMARK;           /* pop original mark */
2641         if (!startop) {
2642             POPBLOCK(cx,PL_curpm);
2643             POPEVAL(cx);
2644             pop_return();
2645         }
2646         lex_end();
2647         LEAVE;
2648         if (optype == OP_REQUIRE) {
2649             char* msg = SvPVx(ERRSV, n_a);
2650             DIE(aTHX_ "%sCompilation failed in require",
2651                 *msg ? msg : "Unknown error\n");
2652         }
2653         else if (startop) {
2654             char* msg = SvPVx(ERRSV, n_a);
2655
2656             POPBLOCK(cx,PL_curpm);
2657             POPEVAL(cx);
2658             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2659                        (*msg ? msg : "Unknown error\n"));
2660         }
2661         SvREFCNT_dec(PL_rs);
2662         PL_rs = SvREFCNT_inc(PL_nrs);
2663 #ifdef USE_THREADS
2664         MUTEX_LOCK(&PL_eval_mutex);
2665         PL_eval_owner = 0;
2666         COND_SIGNAL(&PL_eval_cond);
2667         MUTEX_UNLOCK(&PL_eval_mutex);
2668 #endif /* USE_THREADS */
2669         RETPUSHUNDEF;
2670     }
2671     SvREFCNT_dec(PL_rs);
2672     PL_rs = SvREFCNT_inc(PL_nrs);
2673     PL_compiling.cop_line = 0;
2674     if (startop) {
2675         *startop = PL_eval_root;
2676         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2677         CvOUTSIDE(PL_compcv) = Nullcv;
2678     } else
2679         SAVEFREEOP(PL_eval_root);
2680     if (gimme & G_VOID)
2681         scalarvoid(PL_eval_root);
2682     else if (gimme & G_ARRAY)
2683         list(PL_eval_root);
2684     else
2685         scalar(PL_eval_root);
2686
2687     DEBUG_x(dump_eval());
2688
2689     /* Register with debugger: */
2690     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2691         CV *cv = get_cv("DB::postponed", FALSE);
2692         if (cv) {
2693             dSP;
2694             PUSHMARK(SP);
2695             XPUSHs((SV*)PL_compiling.cop_filegv);
2696             PUTBACK;
2697             call_sv((SV*)cv, G_DISCARD);
2698         }
2699     }
2700
2701     /* compiled okay, so do it */
2702
2703     CvDEPTH(PL_compcv) = 1;
2704     SP = PL_stack_base + POPMARK;               /* pop original mark */
2705     PL_op = saveop;                     /* The caller may need it. */
2706 #ifdef USE_THREADS
2707     MUTEX_LOCK(&PL_eval_mutex);
2708     PL_eval_owner = 0;
2709     COND_SIGNAL(&PL_eval_cond);
2710     MUTEX_UNLOCK(&PL_eval_mutex);
2711 #endif /* USE_THREADS */
2712
2713     RETURNOP(PL_eval_start);
2714 }
2715
2716 STATIC PerlIO *
2717 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2718 {
2719     STRLEN namelen = strlen(name);
2720     PerlIO *fp;
2721
2722     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2723         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2724         char *pmc = SvPV_nolen(pmcsv);
2725         Stat_t pmstat;
2726         Stat_t pmcstat;
2727         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2728             fp = PerlIO_open(name, mode);
2729         }
2730         else {
2731             if (PerlLIO_stat(name, &pmstat) < 0 ||
2732                 pmstat.st_mtime < pmcstat.st_mtime)
2733             {
2734                 fp = PerlIO_open(pmc, mode);
2735             }
2736             else {
2737                 fp = PerlIO_open(name, mode);
2738             }
2739         }
2740         SvREFCNT_dec(pmcsv);
2741     }
2742     else {
2743         fp = PerlIO_open(name, mode);
2744     }
2745     return fp;
2746 }
2747
2748 PP(pp_require)
2749 {
2750     djSP;
2751     register PERL_CONTEXT *cx;
2752     SV *sv;
2753     char *name;
2754     STRLEN len;
2755     char *tryname;
2756     SV *namesv = Nullsv;
2757     SV** svp;
2758     I32 gimme = G_SCALAR;
2759     PerlIO *tryrsfp = 0;
2760     STRLEN n_a;
2761     int filter_has_file = 0;
2762     GV *filter_child_proc = 0;
2763     SV *filter_state = 0;
2764     SV *filter_sub = 0;
2765
2766     sv = POPs;
2767     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2768         if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2769             DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2770                 SvPV(sv,n_a),PL_patchlevel);
2771         RETPUSHYES;
2772     }
2773     name = SvPV(sv, len);
2774     if (!(name && len > 0 && *name))
2775         DIE(aTHX_ "Null filename used");
2776     TAINT_PROPER("require");
2777     if (PL_op->op_type == OP_REQUIRE &&
2778       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2779       *svp != &PL_sv_undef)
2780         RETPUSHYES;
2781
2782     /* prepare to compile file */
2783
2784 #ifdef MACOS_TRADITIONAL
2785     if (strchr(name, ':')
2786 #else
2787     if (*name == '/' ||
2788         (*name == '.' &&
2789             (name[1] == '/' ||
2790              (name[1] == '.' && name[2] == '/')))
2791 #ifdef DOSISH
2792       || (name[0] && name[1] == ':')
2793 #endif
2794 #ifdef WIN32
2795       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2796 #endif
2797 #ifdef VMS
2798         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2799             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2800 #endif
2801 #endif
2802     )
2803     {
2804         tryname = name;
2805         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2806 #ifdef MACOS_TRADITIONAL
2807         /* We consider paths of the form :a:b ambiguous and interpret them first
2808            as global then as local
2809         */
2810     if (name[0] == ':' && !tryrsfp && name[1] != ':' && strchr(name+2, ':'))
2811         goto trylocal;
2812 #endif
2813     }
2814 #ifdef MACOS_TRADITIONAL
2815     else
2816 trylocal: {
2817 #else
2818     else {
2819 #endif
2820         AV *ar = GvAVn(PL_incgv);
2821         I32 i;
2822 #ifdef VMS
2823         char *unixname;
2824         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2825 #endif
2826         {
2827             namesv = NEWSV(806, 0);
2828             for (i = 0; i <= AvFILL(ar); i++) {
2829                 SV *dirsv = *av_fetch(ar, i, TRUE);
2830
2831                 if (SvROK(dirsv)) {
2832                     int count;
2833                     SV *loader = dirsv;
2834
2835                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2836                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2837                     }
2838
2839                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2840                                    PTR2UV(SvANY(loader)), name);
2841                     tryname = SvPVX(namesv);
2842                     tryrsfp = 0;
2843
2844                     ENTER;
2845                     SAVETMPS;
2846                     EXTEND(SP, 2);
2847
2848                     PUSHMARK(SP);
2849                     PUSHs(dirsv);
2850                     PUSHs(sv);
2851                     PUTBACK;
2852                     count = call_sv(loader, G_ARRAY);
2853                     SPAGAIN;
2854
2855                     if (count > 0) {
2856                         int i = 0;
2857                         SV *arg;
2858
2859                         SP -= count - 1;
2860                         arg = SP[i++];
2861
2862                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2863                             arg = SvRV(arg);
2864                         }
2865
2866                         if (SvTYPE(arg) == SVt_PVGV) {
2867                             IO *io = GvIO((GV *)arg);
2868
2869                             ++filter_has_file;
2870
2871                             if (io) {
2872                                 tryrsfp = IoIFP(io);
2873                                 if (IoTYPE(io) == '|') {
2874                                     /* reading from a child process doesn't
2875                                        nest -- when returning from reading
2876                                        the inner module, the outer one is
2877                                        unreadable (closed?)  I've tried to
2878                                        save the gv to manage the lifespan of
2879                                        the pipe, but this didn't help. XXX */
2880                                     filter_child_proc = (GV *)arg;
2881                                     (void)SvREFCNT_inc(filter_child_proc);
2882                                 }
2883                                 else {
2884                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2885                                         PerlIO_close(IoOFP(io));
2886                                     }
2887                                     IoIFP(io) = Nullfp;
2888                                     IoOFP(io) = Nullfp;
2889                                 }
2890                             }
2891
2892                             if (i < count) {
2893                                 arg = SP[i++];
2894                             }
2895                         }
2896
2897                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2898                             filter_sub = arg;
2899                             (void)SvREFCNT_inc(filter_sub);
2900
2901                             if (i < count) {
2902                                 filter_state = SP[i];
2903                                 (void)SvREFCNT_inc(filter_state);
2904                             }
2905
2906                             if (tryrsfp == 0) {
2907                                 tryrsfp = PerlIO_open("/dev/null",
2908                                                       PERL_SCRIPT_MODE);
2909                             }
2910                         }
2911                     }
2912
2913                     PUTBACK;
2914                     FREETMPS;
2915                     LEAVE;
2916
2917                     if (tryrsfp) {
2918                         break;
2919                     }
2920
2921                     filter_has_file = 0;
2922                     if (filter_child_proc) {
2923                         SvREFCNT_dec(filter_child_proc);
2924                         filter_child_proc = 0;
2925                     }
2926                     if (filter_state) {
2927                         SvREFCNT_dec(filter_state);
2928                         filter_state = 0;
2929                     }
2930                     if (filter_sub) {
2931                         SvREFCNT_dec(filter_sub);
2932                         filter_sub = 0;
2933                     }
2934                 }
2935                 else {
2936                     char *dir = SvPVx(dirsv, n_a);
2937 #ifdef MACOS_TRADITIONAL
2938                     /* We have ensured in incpush that library ends with ':' */
2939                     int   dirlen = strlen(dir);
2940                     char *colon  = strchr(dir, ':') ? "" : ":";
2941                     int   colons = (dir[dirlen-1] == ':') + (*name == ':');
2942
2943                     switch (colons) {
2944                     case 2:
2945                         sv_setpvfaTHX_ (namesv, "%s%s%s", colon, dir, name+1);
2946                         break;
2947                     case 1:
2948                         sv_setpvf(aTHX_ namesv, "%s%s%s", colon, dir, name);
2949                         break;
2950                     case 0:
2951                         sv_setpvf(aTHX_ namesv, "%s%s:%s", colon, dir, name);
2952                         break;
2953                     }
2954 #else
2955 #ifdef VMS
2956                     char *unixdir;
2957                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2958                         continue;
2959                     sv_setpv(namesv, unixdir);
2960                     sv_catpv(namesv, unixname);
2961 #else
2962                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
2963 #endif
2964 #endif
2965                     TAINT_PROPER("require");
2966                     tryname = SvPVX(namesv);
2967 #ifdef MACOS_TRADITIONAL
2968                 for (colon = tryname+dirlen; colon = strchr(colon, '/'); )
2969                     *colon++ = ':';
2970 #endif
2971                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2972                     if (tryrsfp) {
2973                         if (tryname[0] == '.' && tryname[1] == '/')
2974                             tryname += 2;
2975                         break;
2976                     }
2977                 }
2978             }
2979         }
2980     }
2981     SAVESPTR(PL_compiling.cop_filegv);
2982     PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2983     SvREFCNT_dec(namesv);
2984     if (!tryrsfp) {
2985         if (PL_op->op_type == OP_REQUIRE) {
2986             char *msgstr = name;
2987             if (namesv) {                       /* did we lookup @INC? */
2988                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2989                 SV *dirmsgsv = NEWSV(0, 0);
2990                 AV *ar = GvAVn(PL_incgv);
2991                 I32 i;
2992                 sv_catpvn(msg, " in @INC", 8);
2993                 if (instr(SvPVX(msg), ".h "))
2994                     sv_catpv(msg, " (change .h to .ph maybe?)");
2995                 if (instr(SvPVX(msg), ".ph "))
2996                     sv_catpv(msg, " (did you run h2ph?)");
2997                 sv_catpv(msg, " (@INC contains:");
2998                 for (i = 0; i <= AvFILL(ar); i++) {
2999                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3000                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3001                     sv_catsv(msg, dirmsgsv);
3002                 }
3003                 sv_catpvn(msg, ")", 1);
3004                 SvREFCNT_dec(dirmsgsv);
3005                 msgstr = SvPV_nolen(msg);
3006             }
3007             DIE(aTHX_ "Can't locate %s", msgstr);
3008         }
3009
3010         RETPUSHUNDEF;
3011     }
3012     else
3013         SETERRNO(0, SS$_NORMAL);
3014
3015     /* Assume success here to prevent recursive requirement. */
3016     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3017         newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
3018
3019     ENTER;
3020     SAVETMPS;
3021     lex_start(sv_2mortal(newSVpvn("",0)));
3022     SAVEGENERICSV(PL_rsfp_filters);
3023     PL_rsfp_filters = Nullav;
3024
3025     PL_rsfp = tryrsfp;
3026     name = savepv(name);
3027     SAVEFREEPV(name);
3028     SAVEHINTS();
3029     PL_hints = 0;
3030     SAVEPPTR(PL_compiling.cop_warnings);
3031     if (PL_dowarn & G_WARN_ALL_ON)
3032         PL_compiling.cop_warnings = WARN_ALL ;
3033     else if (PL_dowarn & G_WARN_ALL_OFF)
3034         PL_compiling.cop_warnings = WARN_NONE ;
3035     else
3036         PL_compiling.cop_warnings = WARN_STD ;
3037
3038     if (filter_sub || filter_child_proc) {
3039         SV *datasv = filter_add(run_user_filter, Nullsv);
3040         IoLINES(datasv) = filter_has_file;
3041         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3042         IoTOP_GV(datasv) = (GV *)filter_state;
3043         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3044     }
3045
3046     /* switch to eval mode */
3047     push_return(PL_op->op_next);
3048     PUSHBLOCK(cx, CXt_EVAL, SP);
3049     PUSHEVAL(cx, name, PL_compiling.cop_filegv);
3050
3051     SAVEI16(PL_compiling.cop_line);
3052     PL_compiling.cop_line = 0;
3053
3054     PUTBACK;
3055 #ifdef USE_THREADS
3056     MUTEX_LOCK(&PL_eval_mutex);
3057     if (PL_eval_owner && PL_eval_owner != thr)
3058         while (PL_eval_owner)
3059             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3060     PL_eval_owner = thr;
3061     MUTEX_UNLOCK(&PL_eval_mutex);
3062 #endif /* USE_THREADS */
3063     return DOCATCH(doeval(G_SCALAR, NULL));
3064 }
3065
3066 PP(pp_dofile)
3067 {
3068     return pp_require();
3069 }
3070
3071 PP(pp_entereval)
3072 {
3073     djSP;
3074     register PERL_CONTEXT *cx;
3075     dPOPss;
3076     I32 gimme = GIMME_V, was = PL_sub_generation;
3077     char tmpbuf[TYPE_DIGITS(long) + 12];
3078     char *safestr;
3079     STRLEN len;
3080     OP *ret;
3081
3082     if (!SvPV(sv,len) || !len)
3083         RETPUSHUNDEF;
3084     TAINT_PROPER("eval");
3085
3086     ENTER;
3087     lex_start(sv);
3088     SAVETMPS;
3089
3090     /* switch to eval mode */
3091
3092     SAVESPTR(PL_compiling.cop_filegv);
3093     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3094     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3095     PL_compiling.cop_line = 1;
3096     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3097        deleting the eval's FILEGV from the stash before gv_check() runs
3098        (i.e. before run-time proper). To work around the coredump that
3099        ensues, we always turn GvMULTI_on for any globals that were
3100        introduced within evals. See force_ident(). GSAR 96-10-12 */
3101     safestr = savepv(tmpbuf);
3102     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3103     SAVEHINTS();
3104     PL_hints = PL_op->op_targ;
3105     SAVEPPTR(PL_compiling.cop_warnings);
3106     if (!specialWARN(PL_compiling.cop_warnings)) {
3107         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3108         SAVEFREESV(PL_compiling.cop_warnings) ;
3109     }
3110
3111     push_return(PL_op->op_next);
3112     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3113     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3114
3115     /* prepare to compile string */
3116
3117     if (PERLDB_LINE && PL_curstash != PL_debstash)
3118         save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3119     PUTBACK;
3120 #ifdef USE_THREADS
3121     MUTEX_LOCK(&PL_eval_mutex);
3122     if (PL_eval_owner && PL_eval_owner != thr)
3123         while (PL_eval_owner)
3124             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3125     PL_eval_owner = thr;
3126     MUTEX_UNLOCK(&PL_eval_mutex);
3127 #endif /* USE_THREADS */
3128     ret = doeval(gimme, NULL);
3129     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3130         && ret != PL_op->op_next) {     /* Successive compilation. */
3131         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3132     }
3133     return DOCATCH(ret);
3134 }
3135
3136 PP(pp_leaveeval)
3137 {
3138     djSP;
3139     register SV **mark;
3140     SV **newsp;
3141     PMOP *newpm;
3142     I32 gimme;
3143     register PERL_CONTEXT *cx;
3144     OP *retop;
3145     U8 save_flags = PL_op -> op_flags;
3146     I32 optype;
3147
3148     POPBLOCK(cx,newpm);
3149     POPEVAL(cx);
3150     retop = pop_return();
3151
3152     TAINT_NOT;
3153     if (gimme == G_VOID)
3154         MARK = newsp;
3155     else if (gimme == G_SCALAR) {
3156         MARK = newsp + 1;
3157         if (MARK <= SP) {
3158             if (SvFLAGS(TOPs) & SVs_TEMP)
3159                 *MARK = TOPs;
3160             else
3161                 *MARK = sv_mortalcopy(TOPs);
3162         }
3163         else {
3164             MEXTEND(mark,0);
3165             *MARK = &PL_sv_undef;
3166         }
3167         SP = MARK;
3168     }
3169     else {
3170         /* in case LEAVE wipes old return values */
3171         for (mark = newsp + 1; mark <= SP; mark++) {
3172             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3173                 *mark = sv_mortalcopy(*mark);
3174                 TAINT_NOT;      /* Each item is independent */
3175             }
3176         }
3177     }
3178     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3179
3180     if (AvFILLp(PL_comppad_name) >= 0)
3181         free_closures();
3182
3183 #ifdef DEBUGGING
3184     assert(CvDEPTH(PL_compcv) == 1);
3185 #endif
3186     CvDEPTH(PL_compcv) = 0;
3187     lex_end();
3188
3189     if (optype == OP_REQUIRE &&
3190         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3191     {
3192         /* Unassume the success we assumed earlier. */
3193         char *name = cx->blk_eval.old_name;
3194         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3195         retop = Perl_die(aTHX_ "%s did not return a true value", name);
3196         /* die_where() did LEAVE, or we won't be here */
3197     }
3198     else {
3199         LEAVE;
3200         if (!(save_flags & OPf_SPECIAL))
3201             sv_setpv(ERRSV,"");
3202     }
3203
3204     RETURNOP(retop);
3205 }
3206
3207 PP(pp_entertry)
3208 {
3209     djSP;
3210     register PERL_CONTEXT *cx;
3211     I32 gimme = GIMME_V;
3212
3213     ENTER;
3214     SAVETMPS;
3215
3216     push_return(cLOGOP->op_other->op_next);
3217     PUSHBLOCK(cx, CXt_EVAL, SP);
3218     PUSHEVAL(cx, 0, 0);
3219     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3220
3221     PL_in_eval = EVAL_INEVAL;
3222     sv_setpv(ERRSV,"");
3223     PUTBACK;
3224     return DOCATCH(PL_op->op_next);
3225 }
3226
3227 PP(pp_leavetry)
3228 {
3229     djSP;
3230     register SV **mark;
3231     SV **newsp;
3232     PMOP *newpm;
3233     I32 gimme;
3234     register PERL_CONTEXT *cx;
3235     I32 optype;
3236
3237     POPBLOCK(cx,newpm);
3238     POPEVAL(cx);
3239     pop_return();
3240
3241     TAINT_NOT;
3242     if (gimme == G_VOID)
3243         SP = newsp;
3244     else if (gimme == G_SCALAR) {
3245         MARK = newsp + 1;
3246         if (MARK <= SP) {
3247             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3248                 *MARK = TOPs;
3249             else
3250                 *MARK = sv_mortalcopy(TOPs);
3251         }
3252         else {
3253             MEXTEND(mark,0);
3254             *MARK = &PL_sv_undef;
3255         }
3256         SP = MARK;
3257     }
3258     else {
3259         /* in case LEAVE wipes old return values */
3260         for (mark = newsp + 1; mark <= SP; mark++) {
3261             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3262                 *mark = sv_mortalcopy(*mark);
3263                 TAINT_NOT;      /* Each item is independent */
3264             }
3265         }
3266     }
3267     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3268
3269     LEAVE;
3270     sv_setpv(ERRSV,"");
3271     RETURN;
3272 }
3273
3274 STATIC void
3275 S_doparseform(pTHX_ SV *sv)
3276 {
3277     STRLEN len;
3278     register char *s = SvPV_force(sv, len);
3279     register char *send = s + len;
3280     register char *base;
3281     register I32 skipspaces = 0;
3282     bool noblank;
3283     bool repeat;
3284     bool postspace = FALSE;
3285     U16 *fops;
3286     register U16 *fpc;
3287     U16 *linepc;
3288     register I32 arg;
3289     bool ischop;
3290
3291     if (len == 0)
3292         Perl_croak(aTHX_ "Null picture in formline");
3293
3294     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3295     fpc = fops;
3296
3297     if (s < send) {
3298         linepc = fpc;
3299         *fpc++ = FF_LINEMARK;
3300         noblank = repeat = FALSE;
3301         base = s;
3302     }
3303
3304     while (s <= send) {
3305         switch (*s++) {
3306         default:
3307             skipspaces = 0;
3308             continue;
3309
3310         case '~':
3311             if (*s == '~') {
3312                 repeat = TRUE;
3313                 *s = ' ';
3314             }
3315             noblank = TRUE;
3316             s[-1] = ' ';
3317             /* FALL THROUGH */
3318         case ' ': case '\t':
3319             skipspaces++;
3320             continue;
3321
3322         case '\n': case 0:
3323             arg = s - base;
3324             skipspaces++;
3325             arg -= skipspaces;
3326             if (arg) {
3327                 if (postspace)
3328                     *fpc++ = FF_SPACE;
3329                 *fpc++ = FF_LITERAL;
3330                 *fpc++ = arg;
3331             }
3332             postspace = FALSE;
3333             if (s <= send)
3334                 skipspaces--;
3335             if (skipspaces) {
3336                 *fpc++ = FF_SKIP;
3337                 *fpc++ = skipspaces;
3338             }
3339             skipspaces = 0;
3340             if (s <= send)
3341                 *fpc++ = FF_NEWLINE;
3342             if (noblank) {
3343                 *fpc++ = FF_BLANK;
3344                 if (repeat)
3345                     arg = fpc - linepc + 1;
3346                 else
3347                     arg = 0;
3348                 *fpc++ = arg;
3349             }
3350             if (s < send) {
3351                 linepc = fpc;
3352                 *fpc++ = FF_LINEMARK;
3353                 noblank = repeat = FALSE;
3354                 base = s;
3355             }
3356             else
3357                 s++;
3358             continue;
3359
3360         case '@':
3361         case '^':
3362             ischop = s[-1] == '^';
3363
3364             if (postspace) {
3365                 *fpc++ = FF_SPACE;
3366                 postspace = FALSE;
3367             }
3368             arg = (s - base) - 1;
3369             if (arg) {
3370                 *fpc++ = FF_LITERAL;
3371                 *fpc++ = arg;
3372             }
3373
3374             base = s - 1;
3375             *fpc++ = FF_FETCH;
3376             if (*s == '*') {
3377                 s++;
3378                 *fpc++ = 0;
3379                 *fpc++ = FF_LINEGLOB;
3380             }
3381             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3382                 arg = ischop ? 512 : 0;
3383                 base = s - 1;
3384                 while (*s == '#')
3385                     s++;
3386                 if (*s == '.') {
3387                     char *f;
3388                     s++;
3389                     f = s;
3390                     while (*s == '#')
3391                         s++;
3392                     arg |= 256 + (s - f);
3393                 }
3394                 *fpc++ = s - base;              /* fieldsize for FETCH */
3395                 *fpc++ = FF_DECIMAL;
3396                 *fpc++ = arg;
3397             }
3398             else {
3399                 I32 prespace = 0;
3400                 bool ismore = FALSE;
3401
3402                 if (*s == '>') {
3403                     while (*++s == '>') ;
3404                     prespace = FF_SPACE;
3405                 }
3406                 else if (*s == '|') {
3407                     while (*++s == '|') ;
3408                     prespace = FF_HALFSPACE;
3409                     postspace = TRUE;
3410                 }
3411                 else {
3412                     if (*s == '<')
3413                         while (*++s == '<') ;
3414                     postspace = TRUE;
3415                 }
3416                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3417                     s += 3;
3418                     ismore = TRUE;
3419                 }
3420                 *fpc++ = s - base;              /* fieldsize for FETCH */
3421
3422                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3423
3424                 if (prespace)
3425                     *fpc++ = prespace;
3426                 *fpc++ = FF_ITEM;
3427                 if (ismore)
3428                     *fpc++ = FF_MORE;
3429                 if (ischop)
3430                     *fpc++ = FF_CHOP;
3431             }
3432             base = s;
3433             skipspaces = 0;
3434             continue;
3435         }
3436     }
3437     *fpc++ = FF_END;
3438
3439     arg = fpc - fops;
3440     { /* need to jump to the next word */
3441         int z;
3442         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3443         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3444         s = SvPVX(sv) + SvCUR(sv) + z;
3445     }
3446     Copy(fops, s, arg, U16);
3447     Safefree(fops);
3448     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3449     SvCOMPILED_on(sv);
3450 }
3451
3452 /*
3453  * The rest of this file was derived from source code contributed
3454  * by Tom Horsley.
3455  *
3456  * NOTE: this code was derived from Tom Horsley's qsort replacement
3457  * and should not be confused with the original code.
3458  */
3459
3460 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3461
3462    Permission granted to distribute under the same terms as perl which are
3463    (briefly):
3464
3465     This program is free software; you can redistribute it and/or modify
3466     it under the terms of either:
3467
3468         a) the GNU General Public License as published by the Free
3469         Software Foundation; either version 1, or (at your option) any
3470         later version, or
3471
3472         b) the "Artistic License" which comes with this Kit.
3473
3474    Details on the perl license can be found in the perl source code which
3475    may be located via the www.perl.com web page.
3476
3477    This is the most wonderfulest possible qsort I can come up with (and
3478    still be mostly portable) My (limited) tests indicate it consistently
3479    does about 20% fewer calls to compare than does the qsort in the Visual
3480    C++ library, other vendors may vary.
3481
3482    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3483    others I invented myself (or more likely re-invented since they seemed
3484    pretty obvious once I watched the algorithm operate for a while).
3485
3486    Most of this code was written while watching the Marlins sweep the Giants
3487    in the 1997 National League Playoffs - no Braves fans allowed to use this
3488    code (just kidding :-).
3489
3490    I realize that if I wanted to be true to the perl tradition, the only
3491    comment in this file would be something like:
3492
3493    ...they shuffled back towards the rear of the line. 'No, not at the
3494    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3495
3496    However, I really needed to violate that tradition just so I could keep
3497    track of what happens myself, not to mention some poor fool trying to
3498    understand this years from now :-).
3499 */
3500
3501 /* ********************************************************** Configuration */
3502
3503 #ifndef QSORT_ORDER_GUESS
3504 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3505 #endif
3506
3507 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3508    future processing - a good max upper bound is log base 2 of memory size
3509    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3510    safely be smaller than that since the program is taking up some space and
3511    most operating systems only let you grab some subset of contiguous
3512    memory (not to mention that you are normally sorting data larger than
3513    1 byte element size :-).
3514 */
3515 #ifndef QSORT_MAX_STACK
3516 #define QSORT_MAX_STACK 32
3517 #endif
3518
3519 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3520    Anything bigger and we use qsort. If you make this too small, the qsort
3521    will probably break (or become less efficient), because it doesn't expect
3522    the middle element of a partition to be the same as the right or left -
3523    you have been warned).
3524 */
3525 #ifndef QSORT_BREAK_EVEN
3526 #define QSORT_BREAK_EVEN 6
3527 #endif
3528
3529 /* ************************************************************* Data Types */
3530
3531 /* hold left and right index values of a partition waiting to be sorted (the
3532    partition includes both left and right - right is NOT one past the end or
3533    anything like that).
3534 */
3535 struct partition_stack_entry {
3536    int left;
3537    int right;
3538 #ifdef QSORT_ORDER_GUESS
3539    int qsort_break_even;
3540 #endif
3541 };
3542
3543 /* ******************************************************* Shorthand Macros */
3544
3545 /* Note that these macros will be used from inside the qsort function where
3546    we happen to know that the variable 'elt_size' contains the size of an
3547    array element and the variable 'temp' points to enough space to hold a
3548    temp element and the variable 'array' points to the array being sorted
3549    and 'compare' is the pointer to the compare routine.
3550
3551    Also note that there are very many highly architecture specific ways
3552    these might be sped up, but this is simply the most generally portable
3553    code I could think of.
3554 */
3555
3556 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3557 */
3558 #define qsort_cmp(elt1, elt2) \
3559    ((*compare)(aTHXo_ array[elt1], array[elt2]))
3560
3561 #ifdef QSORT_ORDER_GUESS
3562 #define QSORT_NOTICE_SWAP swapped++;
3563 #else
3564 #define QSORT_NOTICE_SWAP
3565 #endif
3566
3567 /* swaps contents of array elements elt1, elt2.
3568 */
3569 #define qsort_swap(elt1, elt2) \
3570    STMT_START { \
3571       QSORT_NOTICE_SWAP \
3572       temp = array[elt1]; \
3573       array[elt1] = array[elt2]; \
3574       array[elt2] = temp; \
3575    } STMT_END
3576
3577 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3578    elt3 and elt3 gets elt1.
3579 */
3580 #define qsort_rotate(elt1, elt2, elt3) \
3581    STMT_START { \
3582       QSORT_NOTICE_SWAP \
3583       temp = array[elt1]; \
3584       array[elt1] = array[elt2]; \
3585       array[elt2] = array[elt3]; \
3586       array[elt3] = temp; \
3587    } STMT_END
3588
3589 /* ************************************************************ Debug stuff */
3590
3591 #ifdef QSORT_DEBUG
3592
3593 static void
3594 break_here()
3595 {
3596    return; /* good place to set a breakpoint */
3597 }
3598
3599 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3600
3601 static void
3602 doqsort_all_asserts(
3603    void * array,
3604    size_t num_elts,
3605    size_t elt_size,
3606    int (*compare)(const void * elt1, const void * elt2),
3607    int pc_left, int pc_right, int u_left, int u_right)
3608 {
3609    int i;
3610
3611    qsort_assert(pc_left <= pc_right);
3612    qsort_assert(u_right < pc_left);
3613    qsort_assert(pc_right < u_left);
3614    for (i = u_right + 1; i < pc_left; ++i) {
3615       qsort_assert(qsort_cmp(i, pc_left) < 0);
3616    }
3617    for (i = pc_left; i < pc_right; ++i) {
3618       qsort_assert(qsort_cmp(i, pc_right) == 0);
3619    }
3620    for (i = pc_right + 1; i < u_left; ++i) {
3621       qsort_assert(qsort_cmp(pc_right, i) < 0);
3622    }
3623 }
3624
3625 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3626    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3627                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3628
3629 #else
3630
3631 #define qsort_assert(t) ((void)0)
3632
3633 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3634
3635 #endif
3636
3637 /* ****************************************************************** qsort */
3638
3639 STATIC void
3640 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3641 {
3642    register SV * temp;
3643
3644    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3645    int next_stack_entry = 0;
3646
3647    int part_left;
3648    int part_right;
3649 #ifdef QSORT_ORDER_GUESS
3650    int qsort_break_even;
3651    int swapped;
3652 #endif
3653
3654    /* Make sure we actually have work to do.
3655    */
3656    if (num_elts <= 1) {
3657       return;
3658    }
3659
3660    /* Setup the initial partition definition and fall into the sorting loop
3661    */
3662    part_left = 0;
3663    part_right = (int)(num_elts - 1);
3664 #ifdef QSORT_ORDER_GUESS
3665    qsort_break_even = QSORT_BREAK_EVEN;
3666 #else
3667 #define qsort_break_even QSORT_BREAK_EVEN
3668 #endif
3669    for ( ; ; ) {
3670       if ((part_right - part_left) >= qsort_break_even) {
3671          /* OK, this is gonna get hairy, so lets try to document all the
3672             concepts and abbreviations and variables and what they keep
3673             track of:
3674
3675             pc: pivot chunk - the set of array elements we accumulate in the
3676                 middle of the partition, all equal in value to the original
3677                 pivot element selected. The pc is defined by:
3678
3679                 pc_left - the leftmost array index of the pc
3680                 pc_right - the rightmost array index of the pc
3681
3682                 we start with pc_left == pc_right and only one element
3683                 in the pivot chunk (but it can grow during the scan).
3684
3685             u:  uncompared elements - the set of elements in the partition
3686                 we have not yet compared to the pivot value. There are two
3687                 uncompared sets during the scan - one to the left of the pc
3688                 and one to the right.
3689
3690                 u_right - the rightmost index of the left side's uncompared set
3691                 u_left - the leftmost index of the right side's uncompared set
3692
3693                 The leftmost index of the left sides's uncompared set
3694                 doesn't need its own variable because it is always defined
3695                 by the leftmost edge of the whole partition (part_left). The
3696                 same goes for the rightmost edge of the right partition
3697                 (part_right).
3698
3699                 We know there are no uncompared elements on the left once we
3700                 get u_right < part_left and no uncompared elements on the
3701                 right once u_left > part_right. When both these conditions
3702                 are met, we have completed the scan of the partition.
3703
3704                 Any elements which are between the pivot chunk and the
3705                 uncompared elements should be less than the pivot value on
3706                 the left side and greater than the pivot value on the right
3707                 side (in fact, the goal of the whole algorithm is to arrange
3708                 for that to be true and make the groups of less-than and
3709                 greater-then elements into new partitions to sort again).
3710
3711             As you marvel at the complexity of the code and wonder why it
3712             has to be so confusing. Consider some of the things this level
3713             of confusion brings:
3714
3715             Once I do a compare, I squeeze every ounce of juice out of it. I
3716             never do compare calls I don't have to do, and I certainly never
3717             do redundant calls.
3718
3719             I also never swap any elements unless I can prove there is a
3720             good reason. Many sort algorithms will swap a known value with
3721             an uncompared value just to get things in the right place (or
3722             avoid complexity :-), but that uncompared value, once it gets
3723             compared, may then have to be swapped again. A lot of the
3724             complexity of this code is due to the fact that it never swaps
3725             anything except compared values, and it only swaps them when the
3726             compare shows they are out of position.
3727          */
3728          int pc_left, pc_right;
3729          int u_right, u_left;
3730
3731          int s;
3732
3733          pc_left = ((part_left + part_right) / 2);
3734          pc_right = pc_left;
3735          u_right = pc_left - 1;
3736          u_left = pc_right + 1;
3737
3738          /* Qsort works best when the pivot value is also the median value
3739             in the partition (unfortunately you can't find the median value
3740             without first sorting :-), so to give the algorithm a helping
3741             hand, we pick 3 elements and sort them and use the median value
3742             of that tiny set as the pivot value.
3743
3744             Some versions of qsort like to use the left middle and right as
3745             the 3 elements to sort so they can insure the ends of the
3746             partition will contain values which will stop the scan in the
3747             compare loop, but when you have to call an arbitrarily complex
3748             routine to do a compare, its really better to just keep track of
3749             array index values to know when you hit the edge of the
3750             partition and avoid the extra compare. An even better reason to
3751             avoid using a compare call is the fact that you can drop off the
3752             edge of the array if someone foolishly provides you with an
3753             unstable compare function that doesn't always provide consistent
3754             results.
3755
3756             So, since it is simpler for us to compare the three adjacent
3757             elements in the middle of the partition, those are the ones we
3758             pick here (conveniently pointed at by u_right, pc_left, and
3759             u_left). The values of the left, center, and right elements
3760             are refered to as l c and r in the following comments.
3761          */
3762
3763 #ifdef QSORT_ORDER_GUESS
3764          swapped = 0;
3765 #endif
3766          s = qsort_cmp(u_right, pc_left);
3767          if (s < 0) {
3768             /* l < c */
3769             s = qsort_cmp(pc_left, u_left);
3770             /* if l < c, c < r - already in order - nothing to do */
3771             if (s == 0) {
3772                /* l < c, c == r - already in order, pc grows */
3773                ++pc_right;
3774                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3775             } else if (s > 0) {
3776                /* l < c, c > r - need to know more */
3777                s = qsort_cmp(u_right, u_left);
3778                if (s < 0) {
3779                   /* l < c, c > r, l < r - swap c & r to get ordered */
3780                   qsort_swap(pc_left, u_left);
3781                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3782                } else if (s == 0) {
3783                   /* l < c, c > r, l == r - swap c&r, grow pc */
3784                   qsort_swap(pc_left, u_left);
3785                   --pc_left;
3786                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3787                } else {
3788                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3789                   qsort_rotate(pc_left, u_right, u_left);
3790                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3791                }
3792             }
3793          } else if (s == 0) {
3794             /* l == c */
3795             s = qsort_cmp(pc_left, u_left);
3796             if (s < 0) {
3797                /* l == c, c < r - already in order, grow pc */
3798                --pc_left;
3799                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3800             } else if (s == 0) {
3801                /* l == c, c == r - already in order, grow pc both ways */
3802                --pc_left;
3803                ++pc_right;
3804                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3805             } else {
3806                /* l == c, c > r - swap l & r, grow pc */
3807                qsort_swap(u_right, u_left);
3808                ++pc_right;
3809                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3810             }
3811          } else {
3812             /* l > c */
3813             s = qsort_cmp(pc_left, u_left);
3814             if (s < 0) {
3815                /* l > c, c < r - need to know more */
3816                s = qsort_cmp(u_right, u_left);
3817                if (s < 0) {
3818                   /* l > c, c < r, l < r - swap l & c to get ordered */
3819                   qsort_swap(u_right, pc_left);
3820                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3821                } else if (s == 0) {
3822                   /* l > c, c < r, l == r - swap l & c, grow pc */
3823                   qsort_swap(u_right, pc_left);
3824                   ++pc_right;
3825                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3826                } else {
3827                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3828                   qsort_rotate(u_right, pc_left, u_left);
3829                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3830                }
3831             } else if (s == 0) {
3832                /* l > c, c == r - swap ends, grow pc */
3833                qsort_swap(u_right, u_left);
3834                --pc_left;
3835                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3836             } else {
3837                /* l > c, c > r - swap ends to get in order */
3838                qsort_swap(u_right, u_left);
3839                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3840             }
3841          }
3842          /* We now know the 3 middle elements have been compared and
3843             arranged in the desired order, so we can shrink the uncompared
3844             sets on both sides
3845          */
3846          --u_right;
3847          ++u_left;
3848          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3849
3850          /* The above massive nested if was the simple part :-). We now have
3851             the middle 3 elements ordered and we need to scan through the
3852             uncompared sets on either side, swapping elements that are on
3853             the wrong side or simply shuffling equal elements around to get
3854             all equal elements into the pivot chunk.
3855          */
3856
3857          for ( ; ; ) {
3858             int still_work_on_left;
3859             int still_work_on_right;
3860
3861             /* Scan the uncompared values on the left. If I find a value
3862                equal to the pivot value, move it over so it is adjacent to
3863                the pivot chunk and expand the pivot chunk. If I find a value
3864                less than the pivot value, then just leave it - its already
3865                on the correct side of the partition. If I find a greater
3866                value, then stop the scan.
3867             */
3868             while (still_work_on_left = (u_right >= part_left)) {
3869                s = qsort_cmp(u_right, pc_left);
3870                if (s < 0) {
3871                   --u_right;
3872                } else if (s == 0) {
3873                   --pc_left;
3874                   if (pc_left != u_right) {
3875                      qsort_swap(u_right, pc_left);
3876                   }
3877                   --u_right;
3878                } else {
3879                   break;
3880                }
3881                qsort_assert(u_right < pc_left);
3882                qsort_assert(pc_left <= pc_right);
3883                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3884                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3885             }
3886
3887             /* Do a mirror image scan of uncompared values on the right
3888             */
3889             while (still_work_on_right = (u_left <= part_right)) {
3890                s = qsort_cmp(pc_right, u_left);
3891                if (s < 0) {
3892                   ++u_left;
3893                } else if (s == 0) {
3894                   ++pc_right;
3895                   if (pc_right != u_left) {
3896                      qsort_swap(pc_right, u_left);
3897                   }
3898                   ++u_left;
3899                } else {
3900                   break;
3901                }
3902                qsort_assert(u_left > pc_right);
3903                qsort_assert(pc_left <= pc_right);
3904                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3905                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3906             }
3907
3908             if (still_work_on_left) {
3909                /* I know I have a value on the left side which needs to be
3910                   on the right side, but I need to know more to decide
3911                   exactly the best thing to do with it.
3912                */
3913                if (still_work_on_right) {
3914                   /* I know I have values on both side which are out of
3915                      position. This is a big win because I kill two birds
3916                      with one swap (so to speak). I can advance the
3917                      uncompared pointers on both sides after swapping both
3918                      of them into the right place.
3919                   */
3920                   qsort_swap(u_right, u_left);
3921                   --u_right;
3922                   ++u_left;
3923                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3924                } else {
3925                   /* I have an out of position value on the left, but the
3926                      right is fully scanned, so I "slide" the pivot chunk
3927                      and any less-than values left one to make room for the
3928                      greater value over on the right. If the out of position
3929                      value is immediately adjacent to the pivot chunk (there
3930                      are no less-than values), I can do that with a swap,
3931                      otherwise, I have to rotate one of the less than values
3932                      into the former position of the out of position value
3933                      and the right end of the pivot chunk into the left end
3934                      (got all that?).
3935                   */
3936                   --pc_left;
3937                   if (pc_left == u_right) {
3938                      qsort_swap(u_right, pc_right);
3939                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3940                   } else {
3941                      qsort_rotate(u_right, pc_left, pc_right);
3942                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3943                   }
3944                   --pc_right;
3945                   --u_right;
3946                }
3947             } else if (still_work_on_right) {
3948                /* Mirror image of complex case above: I have an out of
3949                   position value on the right, but the left is fully
3950                   scanned, so I need to shuffle things around to make room
3951                   for the right value on the left.
3952                */
3953                ++pc_right;
3954                if (pc_right == u_left) {
3955                   qsort_swap(u_left, pc_left);
3956                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3957                } else {
3958                   qsort_rotate(pc_right, pc_left, u_left);
3959                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3960                }
3961                ++pc_left;
3962                ++u_left;
3963             } else {
3964                /* No more scanning required on either side of partition,
3965                   break out of loop and figure out next set of partitions
3966                */
3967                break;
3968             }
3969          }
3970
3971          /* The elements in the pivot chunk are now in the right place. They
3972             will never move or be compared again. All I have to do is decide
3973             what to do with the stuff to the left and right of the pivot
3974             chunk.
3975
3976             Notes on the QSORT_ORDER_GUESS ifdef code:
3977
3978             1. If I just built these partitions without swapping any (or
3979                very many) elements, there is a chance that the elements are
3980                already ordered properly (being properly ordered will
3981                certainly result in no swapping, but the converse can't be
3982                proved :-).
3983
3984             2. A (properly written) insertion sort will run faster on
3985                already ordered data than qsort will.
3986
3987             3. Perhaps there is some way to make a good guess about
3988                switching to an insertion sort earlier than partition size 6
3989                (for instance - we could save the partition size on the stack
3990                and increase the size each time we find we didn't swap, thus
3991                switching to insertion sort earlier for partitions with a
3992                history of not swapping).
3993
3994             4. Naturally, if I just switch right away, it will make
3995                artificial benchmarks with pure ascending (or descending)
3996                data look really good, but is that a good reason in general?
3997                Hard to say...
3998          */
3999
4000 #ifdef QSORT_ORDER_GUESS
4001          if (swapped < 3) {
4002 #if QSORT_ORDER_GUESS == 1
4003             qsort_break_even = (part_right - part_left) + 1;
4004 #endif
4005 #if QSORT_ORDER_GUESS == 2
4006             qsort_break_even *= 2;
4007 #endif
4008 #if QSORT_ORDER_GUESS == 3
4009             int prev_break = qsort_break_even;
4010             qsort_break_even *= qsort_break_even;
4011             if (qsort_break_even < prev_break) {
4012                qsort_break_even = (part_right - part_left) + 1;
4013             }
4014 #endif
4015          } else {
4016             qsort_break_even = QSORT_BREAK_EVEN;
4017          }
4018 #endif
4019
4020          if (part_left < pc_left) {
4021             /* There are elements on the left which need more processing.
4022                Check the right as well before deciding what to do.
4023             */
4024             if (pc_right < part_right) {
4025                /* We have two partitions to be sorted. Stack the biggest one
4026                   and process the smallest one on the next iteration. This
4027                   minimizes the stack height by insuring that any additional
4028                   stack entries must come from the smallest partition which
4029                   (because it is smallest) will have the fewest
4030                   opportunities to generate additional stack entries.
4031                */
4032                if ((part_right - pc_right) > (pc_left - part_left)) {
4033                   /* stack the right partition, process the left */
4034                   partition_stack[next_stack_entry].left = pc_right + 1;
4035                   partition_stack[next_stack_entry].right = part_right;
4036 #ifdef QSORT_ORDER_GUESS
4037                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4038 #endif
4039                   part_right = pc_left - 1;
4040                } else {
4041                   /* stack the left partition, process the right */
4042                   partition_stack[next_stack_entry].left = part_left;
4043                   partition_stack[next_stack_entry].right = pc_left - 1;
4044 #ifdef QSORT_ORDER_GUESS
4045                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4046 #endif
4047                   part_left = pc_right + 1;
4048                }
4049                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4050                ++next_stack_entry;
4051             } else {
4052                /* The elements on the left are the only remaining elements
4053                   that need sorting, arrange for them to be processed as the
4054                   next partition.
4055                */
4056                part_right = pc_left - 1;
4057             }
4058          } else if (pc_right < part_right) {
4059             /* There is only one chunk on the right to be sorted, make it
4060                the new partition and loop back around.
4061             */
4062             part_left = pc_right + 1;
4063          } else {
4064             /* This whole partition wound up in the pivot chunk, so
4065                we need to get a new partition off the stack.
4066             */
4067             if (next_stack_entry == 0) {
4068                /* the stack is empty - we are done */
4069                break;
4070             }
4071             --next_stack_entry;
4072             part_left = partition_stack[next_stack_entry].left;
4073             part_right = partition_stack[next_stack_entry].right;
4074 #ifdef QSORT_ORDER_GUESS
4075             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4076 #endif
4077          }
4078       } else {
4079          /* This partition is too small to fool with qsort complexity, just
4080             do an ordinary insertion sort to minimize overhead.
4081          */
4082          int i;
4083          /* Assume 1st element is in right place already, and start checking
4084             at 2nd element to see where it should be inserted.
4085          */
4086          for (i = part_left + 1; i <= part_right; ++i) {
4087             int j;
4088             /* Scan (backwards - just in case 'i' is already in right place)
4089                through the elements already sorted to see if the ith element
4090                belongs ahead of one of them.
4091             */
4092             for (j = i - 1; j >= part_left; --j) {
4093                if (qsort_cmp(i, j) >= 0) {
4094                   /* i belongs right after j
4095                   */
4096                   break;
4097                }
4098             }
4099             ++j;
4100             if (j != i) {
4101                /* Looks like we really need to move some things
4102                */
4103                int k;
4104                temp = array[i];
4105                for (k = i - 1; k >= j; --k)
4106                   array[k + 1] = array[k];
4107                array[j] = temp;
4108             }
4109          }
4110
4111          /* That partition is now sorted, grab the next one, or get out
4112             of the loop if there aren't any more.
4113          */
4114
4115          if (next_stack_entry == 0) {
4116             /* the stack is empty - we are done */
4117             break;
4118          }
4119          --next_stack_entry;
4120          part_left = partition_stack[next_stack_entry].left;
4121          part_right = partition_stack[next_stack_entry].right;
4122 #ifdef QSORT_ORDER_GUESS
4123          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4124 #endif
4125       }
4126    }
4127
4128    /* Believe it or not, the array is sorted at this point! */
4129 }
4130
4131
4132 #ifdef PERL_OBJECT
4133 #define NO_XSLOCKS
4134 #undef this
4135 #define this pPerl
4136 #include "XSUB.h"
4137 #endif
4138
4139
4140 static I32
4141 sortcv(pTHXo_ SV *a, SV *b)
4142 {
4143     dTHR;
4144     I32 oldsaveix = PL_savestack_ix;
4145     I32 oldscopeix = PL_scopestack_ix;
4146     I32 result;
4147     GvSV(PL_firstgv) = a;
4148     GvSV(PL_secondgv) = b;
4149     PL_stack_sp = PL_stack_base;
4150     PL_op = PL_sortcop;
4151     CALLRUNOPS(aTHX);
4152     if (PL_stack_sp != PL_stack_base + 1)
4153         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4154     if (!SvNIOKp(*PL_stack_sp))
4155         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4156     result = SvIV(*PL_stack_sp);
4157     while (PL_scopestack_ix > oldscopeix) {
4158         LEAVE;
4159     }
4160     leave_scope(oldsaveix);
4161     return result;
4162 }
4163
4164
4165 static I32
4166 sv_ncmp(pTHXo_ SV *a, SV *b)
4167 {
4168     NV nv1 = SvNV(a);
4169     NV nv2 = SvNV(b);
4170     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4171 }
4172
4173 static I32
4174 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4175 {
4176     IV iv1 = SvIV(a);
4177     IV iv2 = SvIV(b);
4178     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4179 }
4180 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4181           *svp = Nullsv;                                \
4182           if (PL_amagic_generation) { \
4183             if (SvAMAGIC(left)||SvAMAGIC(right))\
4184                 *svp = amagic_call(left, \
4185                                    right, \
4186                                    CAT2(meth,_amg), \
4187                                    0); \
4188           } \
4189         } STMT_END
4190
4191 static I32
4192 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4193 {
4194     SV *tmpsv;
4195     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4196     if (tmpsv) {
4197         NV d;
4198
4199         if (SvIOK(tmpsv)) {
4200             I32 i = SvIVX(tmpsv);
4201             if (i > 0)
4202                return 1;
4203             return i? -1 : 0;
4204         }
4205         d = SvNV(tmpsv);
4206         if (d > 0)
4207            return 1;
4208         return d? -1 : 0;
4209      }
4210      return sv_ncmp(aTHXo_ a, b);
4211 }
4212
4213 static I32
4214 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4215 {
4216     SV *tmpsv;
4217     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4218     if (tmpsv) {
4219         NV d;
4220
4221         if (SvIOK(tmpsv)) {
4222             I32 i = SvIVX(tmpsv);
4223             if (i > 0)
4224                return 1;
4225             return i? -1 : 0;
4226         }
4227         d = SvNV(tmpsv);
4228         if (d > 0)
4229            return 1;
4230         return d? -1 : 0;
4231     }
4232     return sv_i_ncmp(aTHXo_ a, b);
4233 }
4234
4235 static I32
4236 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4237 {
4238     SV *tmpsv;
4239     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4240     if (tmpsv) {
4241         NV d;
4242
4243         if (SvIOK(tmpsv)) {
4244             I32 i = SvIVX(tmpsv);
4245             if (i > 0)
4246                return 1;
4247             return i? -1 : 0;
4248         }
4249         d = SvNV(tmpsv);
4250         if (d > 0)
4251            return 1;
4252         return d? -1 : 0;
4253     }
4254     return sv_cmp(str1, str2);
4255 }
4256
4257 static I32
4258 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4259 {
4260     SV *tmpsv;
4261     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4262     if (tmpsv) {
4263         NV d;
4264
4265         if (SvIOK(tmpsv)) {
4266             I32 i = SvIVX(tmpsv);
4267             if (i > 0)
4268                return 1;
4269             return i? -1 : 0;
4270         }
4271         d = SvNV(tmpsv);
4272         if (d > 0)
4273            return 1;
4274         return d? -1 : 0;
4275     }
4276     return sv_cmp_locale(str1, str2);
4277 }
4278
4279 static I32
4280 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4281 {
4282     SV *datasv = FILTER_DATA(idx);
4283     int filter_has_file = IoLINES(datasv);
4284     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4285     SV *filter_state = (SV *)IoTOP_GV(datasv);
4286     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4287     int len = 0;
4288
4289     /* I was having segfault trouble under Linux 2.2.5 after a
4290        parse error occured.  (Had to hack around it with a test
4291        for PL_error_count == 0.)  Solaris doesn't segfault --
4292        not sure where the trouble is yet.  XXX */
4293
4294     if (filter_has_file) {
4295         len = FILTER_READ(idx+1, buf_sv, maxlen);
4296     }
4297
4298     if (filter_sub && len >= 0) {
4299         djSP;
4300         int count;
4301
4302         ENTER;
4303         SAVE_DEFSV;
4304         SAVETMPS;
4305         EXTEND(SP, 2);
4306
4307         DEFSV = buf_sv;
4308         PUSHMARK(SP);
4309         PUSHs(sv_2mortal(newSViv(maxlen)));
4310         if (filter_state) {
4311             PUSHs(filter_state);
4312         }
4313         PUTBACK;
4314         count = call_sv(filter_sub, G_SCALAR);
4315         SPAGAIN;
4316
4317         if (count > 0) {
4318             SV *out = POPs;
4319             if (SvOK(out)) {
4320                 len = SvIV(out);
4321             }
4322         }
4323
4324         PUTBACK;
4325         FREETMPS;
4326         LEAVE;
4327     }
4328
4329     if (len <= 0) {
4330         IoLINES(datasv) = 0;
4331         if (filter_child_proc) {
4332             SvREFCNT_dec(filter_child_proc);
4333             IoFMT_GV(datasv) = Nullgv;
4334         }
4335         if (filter_state) {
4336             SvREFCNT_dec(filter_state);
4337             IoTOP_GV(datasv) = Nullgv;
4338         }
4339         if (filter_sub) {
4340             SvREFCNT_dec(filter_sub);
4341             IoBOTTOM_GV(datasv) = Nullgv;
4342         }
4343         filter_del(run_user_filter);
4344     }
4345
4346     return len;
4347 }
4348
4349 #ifdef PERL_OBJECT
4350
4351 static I32
4352 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4353 {
4354     return sv_cmp_locale(str1, str2);
4355 }
4356
4357 static I32
4358 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4359 {
4360     return sv_cmp(str1, str2);
4361 }
4362
4363 #endif /* PERL_OBJECT */