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