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