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