pp_ctl.c

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