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