pp_ctl.c

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