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