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     struct block_loop cxloop;
1658     I32 gimme;
1659     SV **newsp;
1660     PMOP *newpm;
1661     SV **mark;
1662
1663     POPBLOCK(cx,newpm);
1664     mark = newsp;
1665     POPLOOP1(cx);       /* Delay POPLOOP2 until stack values are safe */
1666
1667     TAINT_NOT;
1668     if (gimme == G_VOID)
1669         ; /* do nothing */
1670     else if (gimme == G_SCALAR) {
1671         if (mark < SP)
1672             *++newsp = sv_mortalcopy(*SP);
1673         else
1674             *++newsp = &PL_sv_undef;
1675     }
1676     else {
1677         while (mark < SP) {
1678             *++newsp = sv_mortalcopy(*++mark);
1679             TAINT_NOT;          /* Each item is independent */
1680         }
1681     }
1682     SP = newsp;
1683     PUTBACK;
1684
1685     POPLOOP2();         /* Stack values are safe: release loop vars ... */
1686     PL_curpm = newpm;   /* ... and pop $1 et al */
1687
1688     LEAVE;
1689     LEAVE;
1690
1691     return NORMAL;
1692 }
1693
1694 PP(pp_return)
1695 {
1696     djSP; dMARK;
1697     I32 cxix;
1698     register PERL_CONTEXT *cx;
1699     struct block_sub cxsub;
1700     bool popsub2 = FALSE;
1701     I32 gimme;
1702     SV **newsp;
1703     PMOP *newpm;
1704     I32 optype = 0;
1705
1706     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1707         if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1708             if (cxstack_ix > PL_sortcxix)
1709                 dounwind(PL_sortcxix);
1710             AvARRAY(PL_curstack)[1] = *SP;
1711             PL_stack_sp = PL_stack_base + 1;
1712             return 0;
1713         }
1714     }
1715
1716     cxix = dopoptosub(cxstack_ix);
1717     if (cxix < 0)
1718         DIE(aTHX_ "Can't return outside a subroutine");
1719     if (cxix < cxstack_ix)
1720         dounwind(cxix);
1721
1722     POPBLOCK(cx,newpm);
1723     switch (CxTYPE(cx)) {
1724     case CXt_SUB:
1725         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1726         popsub2 = TRUE;
1727         break;
1728     case CXt_EVAL:
1729         POPEVAL(cx);
1730         if (AvFILLp(PL_comppad_name) >= 0)
1731             free_closures();
1732         lex_end();
1733         if (optype == OP_REQUIRE &&
1734             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1735         {
1736             /* Unassume the success we assumed earlier. */
1737             char *name = cx->blk_eval.old_name;
1738             (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1739             DIE(aTHX_ "%s did not return a true value", name);
1740         }
1741         break;
1742     default:
1743         DIE(aTHX_ "panic: return");
1744     }
1745
1746     TAINT_NOT;
1747     if (gimme == G_SCALAR) {
1748         if (MARK < SP) {
1749             if (popsub2) {
1750                 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1751                     if (SvTEMP(TOPs)) {
1752                         *++newsp = SvREFCNT_inc(*SP);
1753                         FREETMPS;
1754                         sv_2mortal(*newsp);
1755                     } else {
1756                         FREETMPS;
1757                         *++newsp = sv_mortalcopy(*SP);
1758                     }
1759                 } else
1760                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1761             } else
1762                 *++newsp = sv_mortalcopy(*SP);
1763         } else
1764             *++newsp = &PL_sv_undef;
1765     }
1766     else if (gimme == G_ARRAY) {
1767         while (++MARK <= SP) {
1768             *++newsp = (popsub2 && SvTEMP(*MARK))
1769                         ? *MARK : sv_mortalcopy(*MARK);
1770             TAINT_NOT;          /* Each item is independent */
1771         }
1772     }
1773     PL_stack_sp = newsp;
1774
1775     /* Stack values are safe: */
1776     if (popsub2) {
1777         POPSUB2();      /* release CV and @_ ... */
1778     }
1779     PL_curpm = newpm;   /* ... and pop $1 et al */
1780
1781     LEAVE;
1782     return pop_return();
1783 }
1784
1785 PP(pp_last)
1786 {
1787     djSP;
1788     I32 cxix;
1789     register PERL_CONTEXT *cx;
1790     struct block_loop cxloop;
1791     struct block_sub cxsub;
1792     I32 pop2 = 0;
1793     I32 gimme;
1794     I32 optype;
1795     OP *nextop;
1796     SV **newsp;
1797     PMOP *newpm;
1798     SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1799
1800     if (PL_op->op_flags & OPf_SPECIAL) {
1801         cxix = dopoptoloop(cxstack_ix);
1802         if (cxix < 0)
1803             DIE(aTHX_ "Can't \"last\" outside a block");
1804     }
1805     else {
1806         cxix = dopoptolabel(cPVOP->op_pv);
1807         if (cxix < 0)
1808             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1809     }
1810     if (cxix < cxstack_ix)
1811         dounwind(cxix);
1812
1813     POPBLOCK(cx,newpm);
1814     switch (CxTYPE(cx)) {
1815     case CXt_LOOP:
1816         POPLOOP1(cx);   /* Delay POPLOOP2 until stack values are safe */
1817         pop2 = CXt_LOOP;
1818         nextop = cxloop.last_op->op_next;
1819         break;
1820     case CXt_SUB:
1821         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1822         pop2 = CXt_SUB;
1823         nextop = pop_return();
1824         break;
1825     case CXt_EVAL:
1826         POPEVAL(cx);
1827         nextop = pop_return();
1828         break;
1829     default:
1830         DIE(aTHX_ "panic: last");
1831     }
1832
1833     TAINT_NOT;
1834     if (gimme == G_SCALAR) {
1835         if (MARK < SP)
1836             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1837                         ? *SP : sv_mortalcopy(*SP);
1838         else
1839             *++newsp = &PL_sv_undef;
1840     }
1841     else if (gimme == G_ARRAY) {
1842         while (++MARK <= SP) {
1843             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1844                         ? *MARK : sv_mortalcopy(*MARK);
1845             TAINT_NOT;          /* Each item is independent */
1846         }
1847     }
1848     SP = newsp;
1849     PUTBACK;
1850
1851     /* Stack values are safe: */
1852     switch (pop2) {
1853     case CXt_LOOP:
1854         POPLOOP2();     /* release loop vars ... */
1855         LEAVE;
1856         break;
1857     case CXt_SUB:
1858         POPSUB2();      /* release CV and @_ ... */
1859         break;
1860     }
1861     PL_curpm = newpm;   /* ... and pop $1 et al */
1862
1863     LEAVE;
1864     return nextop;
1865 }
1866
1867 PP(pp_next)
1868 {
1869     I32 cxix;
1870     register PERL_CONTEXT *cx;
1871     I32 oldsave;
1872
1873     if (PL_op->op_flags & OPf_SPECIAL) {
1874         cxix = dopoptoloop(cxstack_ix);
1875         if (cxix < 0)
1876             DIE(aTHX_ "Can't \"next\" outside a block");
1877     }
1878     else {
1879         cxix = dopoptolabel(cPVOP->op_pv);
1880         if (cxix < 0)
1881             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1882     }
1883     if (cxix < cxstack_ix)
1884         dounwind(cxix);
1885
1886     TOPBLOCK(cx);
1887     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1888     LEAVE_SCOPE(oldsave);
1889     return cx->blk_loop.next_op;
1890 }
1891
1892 PP(pp_redo)
1893 {
1894     I32 cxix;
1895     register PERL_CONTEXT *cx;
1896     I32 oldsave;
1897
1898     if (PL_op->op_flags & OPf_SPECIAL) {
1899         cxix = dopoptoloop(cxstack_ix);
1900         if (cxix < 0)
1901             DIE(aTHX_ "Can't \"redo\" outside a block");
1902     }
1903     else {
1904         cxix = dopoptolabel(cPVOP->op_pv);
1905         if (cxix < 0)
1906             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1907     }
1908     if (cxix < cxstack_ix)
1909         dounwind(cxix);
1910
1911     TOPBLOCK(cx);
1912     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1913     LEAVE_SCOPE(oldsave);
1914     return cx->blk_loop.redo_op;
1915 }
1916
1917 STATIC OP *
1918 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1919 {
1920     OP *kid;
1921     OP **ops = opstack;
1922     static char too_deep[] = "Target of goto is too deeply nested";
1923
1924     if (ops >= oplimit)
1925         Perl_croak(aTHX_ too_deep);
1926     if (o->op_type == OP_LEAVE ||
1927         o->op_type == OP_SCOPE ||
1928         o->op_type == OP_LEAVELOOP ||
1929         o->op_type == OP_LEAVETRY)
1930     {
1931         *ops++ = cUNOPo->op_first;
1932         if (ops >= oplimit)
1933             Perl_croak(aTHX_ too_deep);
1934     }
1935     *ops = 0;
1936     if (o->op_flags & OPf_KIDS) {
1937         dTHR;
1938         /* First try all the kids at this level, since that's likeliest. */
1939         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1940             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1941                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
1942                 return kid;
1943         }
1944         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1945             if (kid == PL_lastgotoprobe)
1946                 continue;
1947             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1948                 (ops == opstack ||
1949                  (ops[-1]->op_type != OP_NEXTSTATE &&
1950                   ops[-1]->op_type != OP_DBSTATE)))
1951                 *ops++ = kid;
1952             if (o = dofindlabel(kid, label, ops, oplimit))
1953                 return o;
1954         }
1955     }
1956     *ops = 0;
1957     return 0;
1958 }
1959
1960 PP(pp_dump)
1961 {
1962     return pp_goto();
1963     /*NOTREACHED*/
1964 }
1965
1966 PP(pp_goto)
1967 {
1968     djSP;
1969     OP *retop = 0;
1970     I32 ix;
1971     register PERL_CONTEXT *cx;
1972 #define GOTO_DEPTH 64
1973     OP *enterops[GOTO_DEPTH];
1974     char *label;
1975     int do_dump = (PL_op->op_type == OP_DUMP);
1976     static char must_have_label[] = "goto must have label";
1977
1978     label = 0;
1979     if (PL_op->op_flags & OPf_STACKED) {
1980         SV *sv = POPs;
1981         STRLEN n_a;
1982
1983         /* This egregious kludge implements goto &subroutine */
1984         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1985             I32 cxix;
1986             register PERL_CONTEXT *cx;
1987             CV* cv = (CV*)SvRV(sv);
1988             SV** mark;
1989             I32 items = 0;
1990             I32 oldsave;
1991
1992         retry:
1993             if (!CvROOT(cv) && !CvXSUB(cv)) {
1994                 GV *gv = CvGV(cv);
1995                 GV *autogv;
1996                 if (gv) {
1997                     SV *tmpstr;
1998                     /* autoloaded stub? */
1999                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2000                         goto retry;
2001                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2002                                           GvNAMELEN(gv), FALSE);
2003                     if (autogv && (cv = GvCV(autogv)))
2004                         goto retry;
2005                     tmpstr = sv_newmortal();
2006                     gv_efullname3(tmpstr, gv, Nullch);
2007                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2008                 }
2009                 DIE(aTHX_ "Goto undefined subroutine");
2010             }
2011
2012             /* First do some returnish stuff. */
2013             cxix = dopoptosub(cxstack_ix);
2014             if (cxix < 0)
2015                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2016             if (cxix < cxstack_ix)
2017                 dounwind(cxix);
2018             TOPBLOCK(cx);
2019             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2020                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2021             mark = PL_stack_sp;
2022             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2023                 /* put @_ back onto stack */
2024                 AV* av = cx->blk_sub.argarray;
2025
2026                 items = AvFILLp(av) + 1;
2027                 PL_stack_sp++;
2028                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2029                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2030                 PL_stack_sp += items;
2031 #ifndef USE_THREADS
2032                 SvREFCNT_dec(GvAV(PL_defgv));
2033                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2034 #endif /* USE_THREADS */
2035                 /* abandon @_ if it got reified */
2036                 if (AvREAL(av)) {
2037                     (void)sv_2mortal((SV*)av);  /* delay until return */
2038                     av = newAV();
2039                     av_extend(av, items-1);
2040                     AvFLAGS(av) = AVf_REIFY;
2041                     PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2042                 }
2043             }
2044             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2045                 AV* av;
2046                 int i;
2047 #ifdef USE_THREADS
2048                 av = (AV*)PL_curpad[0];
2049 #else
2050                 av = GvAV(PL_defgv);
2051 #endif
2052                 items = AvFILLp(av) + 1;
2053                 PL_stack_sp++;
2054                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2055                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2056                 PL_stack_sp += items;
2057             }
2058             if (CxTYPE(cx) == CXt_SUB &&
2059                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2060                 SvREFCNT_dec(cx->blk_sub.cv);
2061             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2062             LEAVE_SCOPE(oldsave);
2063
2064             /* Now do some callish stuff. */
2065             SAVETMPS;
2066             if (CvXSUB(cv)) {
2067 #ifdef PERL_XSUB_OLDSTYLE
2068                 if (CvOLDSTYLE(cv)) {
2069                     I32 (*fp3)(int,int,int);
2070                     while (SP > mark) {
2071                         SP[1] = SP[0];
2072                         SP--;
2073                     }
2074                     fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
2075                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2076                                    mark - PL_stack_base + 1,
2077                                    items);
2078                     SP = PL_stack_base + items;
2079                 }
2080                 else
2081 #endif /* PERL_XSUB_OLDSTYLE */
2082                 {
2083                     SV **newsp;
2084                     I32 gimme;
2085
2086                     PL_stack_sp--;              /* There is no cv arg. */
2087                     /* Push a mark for the start of arglist */
2088                     PUSHMARK(mark);
2089                     (void)(*CvXSUB(cv))(aTHXo_ cv);
2090                     /* Pop the current context like a decent sub should */
2091                     POPBLOCK(cx, PL_curpm);
2092                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2093                 }
2094                 LEAVE;
2095                 return pop_return();
2096             }
2097             else {
2098                 AV* padlist = CvPADLIST(cv);
2099                 SV** svp = AvARRAY(padlist);
2100                 if (CxTYPE(cx) == CXt_EVAL) {
2101                     PL_in_eval = cx->blk_eval.old_in_eval;
2102                     PL_eval_root = cx->blk_eval.old_eval_root;
2103                     cx->cx_type = CXt_SUB;
2104                     cx->blk_sub.hasargs = 0;
2105                 }
2106                 cx->blk_sub.cv = cv;
2107                 cx->blk_sub.olddepth = CvDEPTH(cv);
2108                 CvDEPTH(cv)++;
2109                 if (CvDEPTH(cv) < 2)
2110                     (void)SvREFCNT_inc(cv);
2111                 else {  /* save temporaries on recursion? */
2112                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2113                         sub_crush_depth(cv);
2114                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2115                         AV *newpad = newAV();
2116                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2117                         I32 ix = AvFILLp((AV*)svp[1]);
2118                         svp = AvARRAY(svp[0]);
2119                         for ( ;ix > 0; ix--) {
2120                             if (svp[ix] != &PL_sv_undef) {
2121                                 char *name = SvPVX(svp[ix]);
2122                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2123                                     || *name == '&')
2124                                 {
2125                                     /* outer lexical or anon code */
2126                                     av_store(newpad, ix,
2127                                         SvREFCNT_inc(oldpad[ix]) );
2128                                 }
2129                                 else {          /* our own lexical */
2130                                     if (*name == '@')
2131                                         av_store(newpad, ix, sv = (SV*)newAV());
2132                                     else if (*name == '%')
2133                                         av_store(newpad, ix, sv = (SV*)newHV());
2134                                     else
2135                                         av_store(newpad, ix, sv = NEWSV(0,0));
2136                                     SvPADMY_on(sv);
2137                                 }
2138                             }
2139                             else {
2140                                 av_store(newpad, ix, sv = NEWSV(0,0));
2141                                 SvPADTMP_on(sv);
2142                             }
2143                         }
2144                         if (cx->blk_sub.hasargs) {
2145                             AV* av = newAV();
2146                             av_extend(av, 0);
2147                             av_store(newpad, 0, (SV*)av);
2148                             AvFLAGS(av) = AVf_REIFY;
2149                         }
2150                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2151                         AvFILLp(padlist) = CvDEPTH(cv);
2152                         svp = AvARRAY(padlist);
2153                     }
2154                 }
2155 #ifdef USE_THREADS
2156                 if (!cx->blk_sub.hasargs) {
2157                     AV* av = (AV*)PL_curpad[0];
2158
2159                     items = AvFILLp(av) + 1;
2160                     if (items) {
2161                         /* Mark is at the end of the stack. */
2162                         EXTEND(SP, items);
2163                         Copy(AvARRAY(av), SP + 1, items, SV*);
2164                         SP += items;
2165                         PUTBACK ;
2166                     }
2167                 }
2168 #endif /* USE_THREADS */
2169                 SAVESPTR(PL_curpad);
2170                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2171 #ifndef USE_THREADS
2172                 if (cx->blk_sub.hasargs)
2173 #endif /* USE_THREADS */
2174                 {
2175                     AV* av = (AV*)PL_curpad[0];
2176                     SV** ary;
2177
2178 #ifndef USE_THREADS
2179                     cx->blk_sub.savearray = GvAV(PL_defgv);
2180                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2181 #endif /* USE_THREADS */
2182                     cx->blk_sub.argarray = av;
2183                     ++mark;
2184
2185                     if (items >= AvMAX(av) + 1) {
2186                         ary = AvALLOC(av);
2187                         if (AvARRAY(av) != ary) {
2188                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2189                             SvPVX(av) = (char*)ary;
2190                         }
2191                         if (items >= AvMAX(av) + 1) {
2192                             AvMAX(av) = items - 1;
2193                             Renew(ary,items+1,SV*);
2194                             AvALLOC(av) = ary;
2195                             SvPVX(av) = (char*)ary;
2196                         }
2197                     }
2198                     Copy(mark,AvARRAY(av),items,SV*);
2199                     AvFILLp(av) = items - 1;
2200                     assert(!AvREAL(av));
2201                     while (items--) {
2202                         if (*mark)
2203                             SvTEMP_off(*mark);
2204                         mark++;
2205                     }
2206                 }
2207                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2208                     /*
2209                      * We do not care about using sv to call CV;
2210                      * it's for informational purposes only.
2211                      */
2212                     SV *sv = GvSV(PL_DBsub);
2213                     CV *gotocv;
2214
2215                     if (PERLDB_SUB_NN) {
2216                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2217                     } else {
2218                         save_item(sv);
2219                         gv_efullname3(sv, CvGV(cv), Nullch);
2220                     }
2221                     if (  PERLDB_GOTO
2222                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2223                         PUSHMARK( PL_stack_sp );
2224                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2225                         PL_stack_sp--;
2226                     }
2227                 }
2228                 RETURNOP(CvSTART(cv));
2229             }
2230         }
2231         else {
2232             label = SvPV(sv,n_a);
2233             if (!(do_dump || *label))
2234                 DIE(aTHX_ must_have_label);
2235         }
2236     }
2237     else if (PL_op->op_flags & OPf_SPECIAL) {
2238         if (! do_dump)
2239             DIE(aTHX_ must_have_label);
2240     }
2241     else
2242         label = cPVOP->op_pv;
2243
2244     if (label && *label) {
2245         OP *gotoprobe = 0;
2246
2247         /* find label */
2248
2249         PL_lastgotoprobe = 0;
2250         *enterops = 0;
2251         for (ix = cxstack_ix; ix >= 0; ix--) {
2252             cx = &cxstack[ix];
2253             switch (CxTYPE(cx)) {
2254             case CXt_EVAL:
2255                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2256                 break;
2257             case CXt_LOOP:
2258                 gotoprobe = cx->blk_oldcop->op_sibling;
2259                 break;
2260             case CXt_SUBST:
2261                 continue;
2262             case CXt_BLOCK:
2263                 if (ix)
2264                     gotoprobe = cx->blk_oldcop->op_sibling;
2265                 else
2266                     gotoprobe = PL_main_root;
2267                 break;
2268             case CXt_SUB:
2269                 if (CvDEPTH(cx->blk_sub.cv)) {
2270                     gotoprobe = CvROOT(cx->blk_sub.cv);
2271                     break;
2272                 }
2273                 /* FALL THROUGH */
2274             case CXt_NULL:
2275                 DIE(aTHX_ "Can't \"goto\" outside a block");
2276             default:
2277                 if (ix)
2278                     DIE(aTHX_ "panic: goto");
2279                 gotoprobe = PL_main_root;
2280                 break;
2281             }
2282             retop = dofindlabel(gotoprobe, label,
2283                                 enterops, enterops + GOTO_DEPTH);
2284             if (retop)
2285                 break;
2286             PL_lastgotoprobe = gotoprobe;
2287         }
2288         if (!retop)
2289             DIE(aTHX_ "Can't find label %s", label);
2290
2291         /* pop unwanted frames */
2292
2293         if (ix < cxstack_ix) {
2294             I32 oldsave;
2295
2296             if (ix < 0)
2297                 ix = 0;
2298             dounwind(ix);
2299             TOPBLOCK(cx);
2300             oldsave = PL_scopestack[PL_scopestack_ix];
2301             LEAVE_SCOPE(oldsave);
2302         }
2303
2304         /* push wanted frames */
2305
2306         if (*enterops && enterops[1]) {
2307             OP *oldop = PL_op;
2308             for (ix = 1; enterops[ix]; ix++) {
2309                 PL_op = enterops[ix];
2310                 /* Eventually we may want to stack the needed arguments
2311                  * for each op.  For now, we punt on the hard ones. */
2312                 if (PL_op->op_type == OP_ENTERITER)
2313                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2314                         label);
2315                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2316             }
2317             PL_op = oldop;
2318         }
2319     }
2320
2321     if (do_dump) {
2322 #ifdef VMS
2323         if (!retop) retop = PL_main_start;
2324 #endif
2325         PL_restartop = retop;
2326         PL_do_undump = TRUE;
2327
2328         my_unexec();
2329
2330         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2331         PL_do_undump = FALSE;
2332     }
2333
2334     RETURNOP(retop);
2335 }
2336
2337 PP(pp_exit)
2338 {
2339     djSP;
2340     I32 anum;
2341
2342     if (MAXARG < 1)
2343         anum = 0;
2344     else {
2345         anum = SvIVx(POPs);
2346 #ifdef VMSISH_EXIT
2347         if (anum == 1 && VMSISH_EXIT)
2348             anum = 0;
2349 #endif
2350     }
2351     my_exit(anum);
2352     PUSHs(&PL_sv_undef);
2353     RETURN;
2354 }
2355
2356 #ifdef NOTYET
2357 PP(pp_nswitch)
2358 {
2359     djSP;
2360     NV value = SvNVx(GvSV(cCOP->cop_gv));
2361     register I32 match = I_32(value);
2362
2363     if (value < 0.0) {
2364         if (((NV)match) > value)
2365             --match;            /* was fractional--truncate other way */
2366     }
2367     match -= cCOP->uop.scop.scop_offset;
2368     if (match < 0)
2369         match = 0;
2370     else if (match > cCOP->uop.scop.scop_max)
2371         match = cCOP->uop.scop.scop_max;
2372     PL_op = cCOP->uop.scop.scop_next[match];
2373     RETURNOP(PL_op);
2374 }
2375
2376 PP(pp_cswitch)
2377 {
2378     djSP;
2379     register I32 match;
2380
2381     if (PL_multiline)
2382         PL_op = PL_op->op_next;                 /* can't assume anything */
2383     else {
2384         STRLEN n_a;
2385         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2386         match -= cCOP->uop.scop.scop_offset;
2387         if (match < 0)
2388             match = 0;
2389         else if (match > cCOP->uop.scop.scop_max)
2390             match = cCOP->uop.scop.scop_max;
2391         PL_op = cCOP->uop.scop.scop_next[match];
2392     }
2393     RETURNOP(PL_op);
2394 }
2395 #endif
2396
2397 /* Eval. */
2398
2399 STATIC void
2400 S_save_lines(pTHX_ AV *array, SV *sv)
2401 {
2402     register char *s = SvPVX(sv);
2403     register char *send = SvPVX(sv) + SvCUR(sv);
2404     register char *t;
2405     register I32 line = 1;
2406
2407     while (s && s < send) {
2408         SV *tmpstr = NEWSV(85,0);
2409
2410         sv_upgrade(tmpstr, SVt_PVMG);
2411         t = strchr(s, '\n');
2412         if (t)
2413             t++;
2414         else
2415             t = send;
2416
2417         sv_setpvn(tmpstr, s, t - s);
2418         av_store(array, line++, tmpstr);
2419         s = t;
2420     }
2421 }
2422
2423 STATIC void *
2424 S_docatch_body(pTHX_ va_list args)
2425 {
2426     CALLRUNOPS(aTHX);
2427     return NULL;
2428 }
2429
2430 STATIC OP *
2431 S_docatch(pTHX_ OP *o)
2432 {
2433     dTHR;
2434     int ret;
2435     OP *oldop = PL_op;
2436
2437 #ifdef DEBUGGING
2438     assert(CATCH_GET == TRUE);
2439 #endif
2440     PL_op = o;
2441  redo_body:
2442     CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_docatch_body));
2443     switch (ret) {
2444     case 0:
2445         break;
2446     case 3:
2447         if (PL_restartop) {
2448             PL_op = PL_restartop;
2449             PL_restartop = 0;
2450             goto redo_body;
2451         }
2452         /* FALL THROUGH */
2453     default:
2454         PL_op = oldop;
2455         JMPENV_JUMP(ret);
2456         /* NOTREACHED */
2457     }
2458     PL_op = oldop;
2459     return Nullop;
2460 }
2461
2462 OP *
2463 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2464 /* sv Text to convert to OP tree. */
2465 /* startop op_free() this to undo. */
2466 /* code Short string id of the caller. */
2467 {
2468     dSP;                                /* Make POPBLOCK work. */
2469     PERL_CONTEXT *cx;
2470     SV **newsp;
2471     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2472     I32 optype;
2473     OP dummy;
2474     OP *oop = PL_op, *rop;
2475     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2476     char *safestr;
2477
2478     ENTER;
2479     lex_start(sv);
2480     SAVETMPS;
2481     /* switch to eval mode */
2482
2483     if (PL_curcop == &PL_compiling) {
2484         SAVESPTR(PL_compiling.cop_stash);
2485         PL_compiling.cop_stash = PL_curstash;
2486     }
2487     SAVESPTR(PL_compiling.cop_filegv);
2488     SAVEI16(PL_compiling.cop_line);
2489     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2490     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2491     PL_compiling.cop_line = 1;
2492     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2493        deleting the eval's FILEGV from the stash before gv_check() runs
2494        (i.e. before run-time proper). To work around the coredump that
2495        ensues, we always turn GvMULTI_on for any globals that were
2496        introduced within evals. See force_ident(). GSAR 96-10-12 */
2497     safestr = savepv(tmpbuf);
2498     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2499     SAVEHINTS();
2500 #ifdef OP_IN_REGISTER
2501     PL_opsave = op;
2502 #else
2503     SAVEPPTR(PL_op);
2504 #endif
2505     PL_hints = 0;
2506
2507     PL_op = &dummy;
2508     PL_op->op_type = OP_ENTEREVAL;
2509     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2510     PUSHBLOCK(cx, CXt_EVAL, SP);
2511     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2512     rop = doeval(G_SCALAR, startop);
2513     POPBLOCK(cx,PL_curpm);
2514     POPEVAL(cx);
2515
2516     (*startop)->op_type = OP_NULL;
2517     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2518     lex_end();
2519     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2520     LEAVE;
2521     if (PL_curcop == &PL_compiling)
2522         PL_compiling.op_private = PL_hints;
2523 #ifdef OP_IN_REGISTER
2524     op = PL_opsave;
2525 #endif
2526     return rop;
2527 }
2528
2529 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2530 STATIC OP *
2531 S_doeval(pTHX_ int gimme, OP** startop)
2532 {
2533     dSP;
2534     OP *saveop = PL_op;
2535     HV *newstash;
2536     CV *caller;
2537     AV* comppadlist;
2538     I32 i;
2539
2540     PL_in_eval = EVAL_INEVAL;
2541
2542     PUSHMARK(SP);
2543
2544     /* set up a scratch pad */
2545
2546     SAVEI32(PL_padix);
2547     SAVESPTR(PL_curpad);
2548     SAVESPTR(PL_comppad);
2549     SAVESPTR(PL_comppad_name);
2550     SAVEI32(PL_comppad_name_fill);
2551     SAVEI32(PL_min_intro_pending);
2552     SAVEI32(PL_max_intro_pending);
2553
2554     caller = PL_compcv;
2555     for (i = cxstack_ix - 1; i >= 0; i--) {
2556         PERL_CONTEXT *cx = &cxstack[i];
2557         if (CxTYPE(cx) == CXt_EVAL)
2558             break;
2559         else if (CxTYPE(cx) == CXt_SUB) {
2560             caller = cx->blk_sub.cv;
2561             break;
2562         }
2563     }
2564
2565     SAVESPTR(PL_compcv);
2566     PL_compcv = (CV*)NEWSV(1104,0);
2567     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2568     CvEVAL_on(PL_compcv);
2569 #ifdef USE_THREADS
2570     CvOWNER(PL_compcv) = 0;
2571     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2572     MUTEX_INIT(CvMUTEXP(PL_compcv));
2573 #endif /* USE_THREADS */
2574
2575     PL_comppad = newAV();
2576     av_push(PL_comppad, Nullsv);
2577     PL_curpad = AvARRAY(PL_comppad);
2578     PL_comppad_name = newAV();
2579     PL_comppad_name_fill = 0;
2580     PL_min_intro_pending = 0;
2581     PL_padix = 0;
2582 #ifdef USE_THREADS
2583     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2584     PL_curpad[0] = (SV*)newAV();
2585     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2586 #endif /* USE_THREADS */
2587
2588     comppadlist = newAV();
2589     AvREAL_off(comppadlist);
2590     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2591     av_store(comppadlist, 1, (SV*)PL_comppad);
2592     CvPADLIST(PL_compcv) = comppadlist;
2593
2594     if (!saveop || saveop->op_type != OP_REQUIRE)
2595         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2596
2597     SAVEFREESV(PL_compcv);
2598
2599     /* make sure we compile in the right package */
2600
2601     newstash = PL_curcop->cop_stash;
2602     if (PL_curstash != newstash) {
2603         SAVESPTR(PL_curstash);
2604         PL_curstash = newstash;
2605     }
2606     SAVESPTR(PL_beginav);
2607     PL_beginav = newAV();
2608     SAVEFREESV(PL_beginav);
2609
2610     /* try to compile it */
2611
2612     PL_eval_root = Nullop;
2613     PL_error_count = 0;
2614     PL_curcop = &PL_compiling;
2615     PL_curcop->cop_arybase = 0;
2616     SvREFCNT_dec(PL_rs);
2617     PL_rs = newSVpvn("\n", 1);
2618     if (saveop && saveop->op_flags & OPf_SPECIAL)
2619         PL_in_eval |= EVAL_KEEPERR;
2620     else
2621         sv_setpv(ERRSV,"");
2622     if (yyparse() || PL_error_count || !PL_eval_root) {
2623         SV **newsp;
2624         I32 gimme;
2625         PERL_CONTEXT *cx;
2626         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2627         STRLEN n_a;
2628
2629         PL_op = saveop;
2630         if (PL_eval_root) {
2631             op_free(PL_eval_root);
2632             PL_eval_root = Nullop;
2633         }
2634         SP = PL_stack_base + POPMARK;           /* pop original mark */
2635         if (!startop) {
2636             POPBLOCK(cx,PL_curpm);
2637             POPEVAL(cx);
2638             pop_return();
2639         }
2640         lex_end();
2641         LEAVE;
2642         if (optype == OP_REQUIRE) {
2643             char* msg = SvPVx(ERRSV, n_a);
2644             DIE(aTHX_ "%sCompilation failed in require",
2645                 *msg ? msg : "Unknown error\n");
2646         }
2647         else if (startop) {
2648             char* msg = SvPVx(ERRSV, n_a);
2649
2650             POPBLOCK(cx,PL_curpm);
2651             POPEVAL(cx);
2652             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2653                        (*msg ? msg : "Unknown error\n"));
2654         }
2655         SvREFCNT_dec(PL_rs);
2656         PL_rs = SvREFCNT_inc(PL_nrs);
2657 #ifdef USE_THREADS
2658         MUTEX_LOCK(&PL_eval_mutex);
2659         PL_eval_owner = 0;
2660         COND_SIGNAL(&PL_eval_cond);
2661         MUTEX_UNLOCK(&PL_eval_mutex);
2662 #endif /* USE_THREADS */
2663         RETPUSHUNDEF;
2664     }
2665     SvREFCNT_dec(PL_rs);
2666     PL_rs = SvREFCNT_inc(PL_nrs);
2667     PL_compiling.cop_line = 0;
2668     if (startop) {
2669         *startop = PL_eval_root;
2670         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2671         CvOUTSIDE(PL_compcv) = Nullcv;
2672     } else
2673         SAVEFREEOP(PL_eval_root);
2674     if (gimme & G_VOID)
2675         scalarvoid(PL_eval_root);
2676     else if (gimme & G_ARRAY)
2677         list(PL_eval_root);
2678     else
2679         scalar(PL_eval_root);
2680
2681     DEBUG_x(dump_eval());
2682
2683     /* Register with debugger: */
2684     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2685         CV *cv = get_cv("DB::postponed", FALSE);
2686         if (cv) {
2687             dSP;
2688             PUSHMARK(SP);
2689             XPUSHs((SV*)PL_compiling.cop_filegv);
2690             PUTBACK;
2691             call_sv((SV*)cv, G_DISCARD);
2692         }
2693     }
2694
2695     /* compiled okay, so do it */
2696
2697     CvDEPTH(PL_compcv) = 1;
2698     SP = PL_stack_base + POPMARK;               /* pop original mark */
2699     PL_op = saveop;                     /* The caller may need it. */
2700 #ifdef USE_THREADS
2701     MUTEX_LOCK(&PL_eval_mutex);
2702     PL_eval_owner = 0;
2703     COND_SIGNAL(&PL_eval_cond);
2704     MUTEX_UNLOCK(&PL_eval_mutex);
2705 #endif /* USE_THREADS */
2706
2707     RETURNOP(PL_eval_start);
2708 }
2709
2710 STATIC PerlIO *
2711 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2712 {
2713     STRLEN namelen = strlen(name);
2714     PerlIO *fp;
2715
2716     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2717         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2718         char *pmc = SvPV_nolen(pmcsv);
2719         Stat_t pmstat;
2720         Stat_t pmcstat;
2721         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2722             fp = PerlIO_open(name, mode);
2723         }
2724         else {
2725             if (PerlLIO_stat(name, &pmstat) < 0 ||
2726                 pmstat.st_mtime < pmcstat.st_mtime)
2727             {
2728                 fp = PerlIO_open(pmc, mode);
2729             }
2730             else {
2731                 fp = PerlIO_open(name, mode);
2732             }
2733         }
2734         SvREFCNT_dec(pmcsv);
2735     }
2736     else {
2737         fp = PerlIO_open(name, mode);
2738     }
2739     return fp;
2740 }
2741
2742 PP(pp_require)
2743 {
2744     djSP;
2745     register PERL_CONTEXT *cx;
2746     SV *sv;
2747     char *name;
2748     STRLEN len;
2749     char *tryname;
2750     SV *namesv = Nullsv;
2751     SV** svp;
2752     I32 gimme = G_SCALAR;
2753     PerlIO *tryrsfp = 0;
2754     STRLEN n_a;
2755     int filter_has_file = 0;
2756     GV *filter_child_proc = 0;
2757     SV *filter_state = 0;
2758     SV *filter_sub = 0;
2759
2760     sv = POPs;
2761     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2762         if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2763             DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2764                 SvPV(sv,n_a),PL_patchlevel);
2765         RETPUSHYES;
2766     }
2767     name = SvPV(sv, len);
2768     if (!(name && len > 0 && *name))
2769         DIE(aTHX_ "Null filename used");
2770     TAINT_PROPER("require");
2771     if (PL_op->op_type == OP_REQUIRE &&
2772       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2773       *svp != &PL_sv_undef)
2774         RETPUSHYES;
2775
2776     /* prepare to compile file */
2777
2778     if (*name == '/' ||
2779         (*name == '.' &&
2780             (name[1] == '/' ||
2781              (name[1] == '.' && name[2] == '/')))
2782 #ifdef DOSISH
2783       || (name[0] && name[1] == ':')
2784 #endif
2785 #ifdef WIN32
2786       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2787 #endif
2788 #ifdef VMS
2789         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2790             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2791 #endif
2792     )
2793     {
2794         tryname = name;
2795         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2796     }
2797     else {
2798         AV *ar = GvAVn(PL_incgv);
2799         I32 i;
2800 #ifdef VMS
2801         char *unixname;
2802         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2803 #endif
2804         {
2805             namesv = NEWSV(806, 0);
2806             for (i = 0; i <= AvFILL(ar); i++) {
2807                 SV *dirsv = *av_fetch(ar, i, TRUE);
2808
2809                 if (SvROK(dirsv)) {
2810                     int count;
2811                     SV *loader = dirsv;
2812
2813                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2814                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2815                     }
2816
2817                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%lx/%s",
2818                                    SvANY(loader), name);
2819                     tryname = SvPVX(namesv);
2820                     tryrsfp = 0;
2821
2822                     ENTER;
2823                     SAVETMPS;
2824                     EXTEND(SP, 2);
2825
2826                     PUSHMARK(SP);
2827                     PUSHs(dirsv);
2828                     PUSHs(sv);
2829                     PUTBACK;
2830                     count = call_sv(loader, G_ARRAY);
2831                     SPAGAIN;
2832
2833                     if (count > 0) {
2834                         int i = 0;
2835                         SV *arg;
2836
2837                         SP -= count - 1;
2838                         arg = SP[i++];
2839
2840                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2841                             arg = SvRV(arg);
2842                         }
2843
2844                         if (SvTYPE(arg) == SVt_PVGV) {
2845                             IO *io = GvIO((GV *)arg);
2846
2847                             ++filter_has_file;
2848
2849                             if (io) {
2850                                 tryrsfp = IoIFP(io);
2851                                 if (IoTYPE(io) == '|') {
2852                                     /* reading from a child process doesn't
2853                                        nest -- when returning from reading
2854                                        the inner module, the outer one is
2855                                        unreadable (closed?)  I've tried to
2856                                        save the gv to manage the lifespan of
2857                                        the pipe, but this didn't help. XXX */
2858                                     filter_child_proc = (GV *)arg;
2859                                     (void)SvREFCNT_inc(filter_child_proc);
2860                                 }
2861                                 else {
2862                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2863                                         PerlIO_close(IoOFP(io));
2864                                     }
2865                                     IoIFP(io) = Nullfp;
2866                                     IoOFP(io) = Nullfp;
2867                                 }
2868                             }
2869
2870                             if (i < count) {
2871                                 arg = SP[i++];
2872                             }
2873                         }
2874
2875                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2876                             filter_sub = arg;
2877                             (void)SvREFCNT_inc(filter_sub);
2878
2879                             if (i < count) {
2880                                 filter_state = SP[i];
2881                                 (void)SvREFCNT_inc(filter_state);
2882                             }
2883
2884                             if (tryrsfp == 0) {
2885                                 tryrsfp = PerlIO_open("/dev/null",
2886                                                       PERL_SCRIPT_MODE);
2887                             }
2888                         }
2889                     }
2890
2891                     PUTBACK;
2892                     FREETMPS;
2893                     LEAVE;
2894
2895                     if (tryrsfp) {
2896                         break;
2897                     }
2898
2899                     filter_has_file = 0;
2900                     if (filter_child_proc) {
2901                         SvREFCNT_dec(filter_child_proc);
2902                         filter_child_proc = 0;
2903                     }
2904                     if (filter_state) {
2905                         SvREFCNT_dec(filter_state);
2906                         filter_state = 0;
2907                     }
2908                     if (filter_sub) {
2909                         SvREFCNT_dec(filter_sub);
2910                         filter_sub = 0;
2911                     }
2912                 }
2913                 else {
2914                     char *dir = SvPVx(dirsv, n_a);
2915 #ifdef VMS
2916                     char *unixdir;
2917                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2918                         continue;
2919                     sv_setpv(namesv, unixdir);
2920                     sv_catpv(namesv, unixname);
2921 #else
2922                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
2923 #endif
2924                     TAINT_PROPER("require");
2925                     tryname = SvPVX(namesv);
2926                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2927                     if (tryrsfp) {
2928                         if (tryname[0] == '.' && tryname[1] == '/')
2929                             tryname += 2;
2930                         break;
2931                     }
2932                 }
2933             }
2934         }
2935     }
2936     SAVESPTR(PL_compiling.cop_filegv);
2937     PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2938     SvREFCNT_dec(namesv);
2939     if (!tryrsfp) {
2940         if (PL_op->op_type == OP_REQUIRE) {
2941             char *msgstr = name;
2942             if (namesv) {                       /* did we lookup @INC? */
2943                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2944                 SV *dirmsgsv = NEWSV(0, 0);
2945                 AV *ar = GvAVn(PL_incgv);
2946                 I32 i;
2947                 sv_catpvn(msg, " in @INC", 8);
2948                 if (instr(SvPVX(msg), ".h "))
2949                     sv_catpv(msg, " (change .h to .ph maybe?)");
2950                 if (instr(SvPVX(msg), ".ph "))
2951                     sv_catpv(msg, " (did you run h2ph?)");
2952                 sv_catpv(msg, " (@INC contains:");
2953                 for (i = 0; i <= AvFILL(ar); i++) {
2954                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2955                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
2956                     sv_catsv(msg, dirmsgsv);
2957                 }
2958                 sv_catpvn(msg, ")", 1);
2959                 SvREFCNT_dec(dirmsgsv);
2960                 msgstr = SvPV_nolen(msg);
2961             }
2962             DIE(aTHX_ "Can't locate %s", msgstr);
2963         }
2964
2965         RETPUSHUNDEF;
2966     }
2967     else
2968         SETERRNO(0, SS$_NORMAL);
2969
2970     /* Assume success here to prevent recursive requirement. */
2971     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2972         newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2973
2974     ENTER;
2975     SAVETMPS;
2976     lex_start(sv_2mortal(newSVpvn("",0)));
2977     SAVEGENERICSV(PL_rsfp_filters);
2978     PL_rsfp_filters = Nullav;
2979
2980     PL_rsfp = tryrsfp;
2981     name = savepv(name);
2982     SAVEFREEPV(name);
2983     SAVEHINTS();
2984     PL_hints = 0;
2985     SAVEPPTR(PL_compiling.cop_warnings);
2986     if (PL_dowarn & G_WARN_ALL_ON)
2987         PL_compiling.cop_warnings = WARN_ALL ;
2988     else if (PL_dowarn & G_WARN_ALL_OFF)
2989         PL_compiling.cop_warnings = WARN_NONE ;
2990     else
2991         PL_compiling.cop_warnings = WARN_STD ;
2992
2993     if (filter_sub || filter_child_proc) {
2994         SV *datasv = filter_add(run_user_filter, Nullsv);
2995         IoLINES(datasv) = filter_has_file;
2996         IoFMT_GV(datasv) = (GV *)filter_child_proc;
2997         IoTOP_GV(datasv) = (GV *)filter_state;
2998         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
2999     }
3000
3001     /* switch to eval mode */
3002     push_return(PL_op->op_next);
3003     PUSHBLOCK(cx, CXt_EVAL, SP);
3004     PUSHEVAL(cx, name, PL_compiling.cop_filegv);
3005
3006     SAVEI16(PL_compiling.cop_line);
3007     PL_compiling.cop_line = 0;
3008
3009     PUTBACK;
3010 #ifdef USE_THREADS
3011     MUTEX_LOCK(&PL_eval_mutex);
3012     if (PL_eval_owner && PL_eval_owner != thr)
3013         while (PL_eval_owner)
3014             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3015     PL_eval_owner = thr;
3016     MUTEX_UNLOCK(&PL_eval_mutex);
3017 #endif /* USE_THREADS */
3018     return DOCATCH(doeval(G_SCALAR, NULL));
3019 }
3020
3021 PP(pp_dofile)
3022 {
3023     return pp_require();
3024 }
3025
3026 PP(pp_entereval)
3027 {
3028     djSP;
3029     register PERL_CONTEXT *cx;
3030     dPOPss;
3031     I32 gimme = GIMME_V, was = PL_sub_generation;
3032     char tmpbuf[TYPE_DIGITS(long) + 12];
3033     char *safestr;
3034     STRLEN len;
3035     OP *ret;
3036
3037     if (!SvPV(sv,len) || !len)
3038         RETPUSHUNDEF;
3039     TAINT_PROPER("eval");
3040
3041     ENTER;
3042     lex_start(sv);
3043     SAVETMPS;
3044
3045     /* switch to eval mode */
3046
3047     SAVESPTR(PL_compiling.cop_filegv);
3048     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3049     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3050     PL_compiling.cop_line = 1;
3051     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3052        deleting the eval's FILEGV from the stash before gv_check() runs
3053        (i.e. before run-time proper). To work around the coredump that
3054        ensues, we always turn GvMULTI_on for any globals that were
3055        introduced within evals. See force_ident(). GSAR 96-10-12 */
3056     safestr = savepv(tmpbuf);
3057     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3058     SAVEHINTS();
3059     PL_hints = PL_op->op_targ;
3060     SAVEPPTR(PL_compiling.cop_warnings);
3061     if (!specialWARN(PL_compiling.cop_warnings)) {
3062         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3063         SAVEFREESV(PL_compiling.cop_warnings) ;
3064     }
3065
3066     push_return(PL_op->op_next);
3067     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3068     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3069
3070     /* prepare to compile string */
3071
3072     if (PERLDB_LINE && PL_curstash != PL_debstash)
3073         save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3074     PUTBACK;
3075 #ifdef USE_THREADS
3076     MUTEX_LOCK(&PL_eval_mutex);
3077     if (PL_eval_owner && PL_eval_owner != thr)
3078         while (PL_eval_owner)
3079             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3080     PL_eval_owner = thr;
3081     MUTEX_UNLOCK(&PL_eval_mutex);
3082 #endif /* USE_THREADS */
3083     ret = doeval(gimme, NULL);
3084     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3085         && ret != PL_op->op_next) {     /* Successive compilation. */
3086         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3087     }
3088     return DOCATCH(ret);
3089 }
3090
3091 PP(pp_leaveeval)
3092 {
3093     djSP;
3094     register SV **mark;
3095     SV **newsp;
3096     PMOP *newpm;
3097     I32 gimme;
3098     register PERL_CONTEXT *cx;
3099     OP *retop;
3100     U8 save_flags = PL_op -> op_flags;
3101     I32 optype;
3102
3103     POPBLOCK(cx,newpm);
3104     POPEVAL(cx);
3105     retop = pop_return();
3106
3107     TAINT_NOT;
3108     if (gimme == G_VOID)
3109         MARK = newsp;
3110     else if (gimme == G_SCALAR) {
3111         MARK = newsp + 1;
3112         if (MARK <= SP) {
3113             if (SvFLAGS(TOPs) & SVs_TEMP)
3114                 *MARK = TOPs;
3115             else
3116                 *MARK = sv_mortalcopy(TOPs);
3117         }
3118         else {
3119             MEXTEND(mark,0);
3120             *MARK = &PL_sv_undef;
3121         }
3122     }
3123     else {
3124         /* in case LEAVE wipes old return values */
3125         for (mark = newsp + 1; mark <= SP; mark++) {
3126             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3127                 *mark = sv_mortalcopy(*mark);
3128                 TAINT_NOT;      /* Each item is independent */
3129             }
3130         }
3131     }
3132     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3133
3134     if (AvFILLp(PL_comppad_name) >= 0)
3135         free_closures();
3136
3137 #ifdef DEBUGGING
3138     assert(CvDEPTH(PL_compcv) == 1);
3139 #endif
3140     CvDEPTH(PL_compcv) = 0;
3141     lex_end();
3142
3143     if (optype == OP_REQUIRE &&
3144         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3145     {
3146         /* Unassume the success we assumed earlier. */
3147         char *name = cx->blk_eval.old_name;
3148         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3149         retop = Perl_die(aTHX_ "%s did not return a true value", name);
3150         /* die_where() did LEAVE, or we won't be here */
3151     }
3152     else {
3153         LEAVE;
3154         if (!(save_flags & OPf_SPECIAL))
3155             sv_setpv(ERRSV,"");
3156     }
3157
3158     RETURNOP(retop);
3159 }
3160
3161 PP(pp_entertry)
3162 {
3163     djSP;
3164     register PERL_CONTEXT *cx;
3165     I32 gimme = GIMME_V;
3166
3167     ENTER;
3168     SAVETMPS;
3169
3170     push_return(cLOGOP->op_other->op_next);
3171     PUSHBLOCK(cx, CXt_EVAL, SP);
3172     PUSHEVAL(cx, 0, 0);
3173     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3174
3175     PL_in_eval = EVAL_INEVAL;
3176     sv_setpv(ERRSV,"");
3177     PUTBACK;
3178     return DOCATCH(PL_op->op_next);
3179 }
3180
3181 PP(pp_leavetry)
3182 {
3183     djSP;
3184     register SV **mark;
3185     SV **newsp;
3186     PMOP *newpm;
3187     I32 gimme;
3188     register PERL_CONTEXT *cx;
3189     I32 optype;
3190
3191     POPBLOCK(cx,newpm);
3192     POPEVAL(cx);
3193     pop_return();
3194
3195     TAINT_NOT;
3196     if (gimme == G_VOID)
3197         SP = newsp;
3198     else if (gimme == G_SCALAR) {
3199         MARK = newsp + 1;
3200         if (MARK <= SP) {
3201             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3202                 *MARK = TOPs;
3203             else
3204                 *MARK = sv_mortalcopy(TOPs);
3205         }
3206         else {
3207             MEXTEND(mark,0);
3208             *MARK = &PL_sv_undef;
3209         }
3210         SP = MARK;
3211     }
3212     else {
3213         /* in case LEAVE wipes old return values */
3214         for (mark = newsp + 1; mark <= SP; mark++) {
3215             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3216                 *mark = sv_mortalcopy(*mark);
3217                 TAINT_NOT;      /* Each item is independent */
3218             }
3219         }
3220     }
3221     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3222
3223     LEAVE;
3224     sv_setpv(ERRSV,"");
3225     RETURN;
3226 }
3227
3228 STATIC void
3229 S_doparseform(pTHX_ SV *sv)
3230 {
3231     STRLEN len;
3232     register char *s = SvPV_force(sv, len);
3233     register char *send = s + len;
3234     register char *base;
3235     register I32 skipspaces = 0;
3236     bool noblank;
3237     bool repeat;
3238     bool postspace = FALSE;
3239     U16 *fops;
3240     register U16 *fpc;
3241     U16 *linepc;
3242     register I32 arg;
3243     bool ischop;
3244
3245     if (len == 0)
3246         Perl_croak(aTHX_ "Null picture in formline");
3247
3248     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3249     fpc = fops;
3250
3251     if (s < send) {
3252         linepc = fpc;
3253         *fpc++ = FF_LINEMARK;
3254         noblank = repeat = FALSE;
3255         base = s;
3256     }
3257
3258     while (s <= send) {
3259         switch (*s++) {
3260         default:
3261             skipspaces = 0;
3262             continue;
3263
3264         case '~':
3265             if (*s == '~') {
3266                 repeat = TRUE;
3267                 *s = ' ';
3268             }
3269             noblank = TRUE;
3270             s[-1] = ' ';
3271             /* FALL THROUGH */
3272         case ' ': case '\t':
3273             skipspaces++;
3274             continue;
3275
3276         case '\n': case 0:
3277             arg = s - base;
3278             skipspaces++;
3279             arg -= skipspaces;
3280             if (arg) {
3281                 if (postspace)
3282                     *fpc++ = FF_SPACE;
3283                 *fpc++ = FF_LITERAL;
3284                 *fpc++ = arg;
3285             }
3286             postspace = FALSE;
3287             if (s <= send)
3288                 skipspaces--;
3289             if (skipspaces) {
3290                 *fpc++ = FF_SKIP;
3291                 *fpc++ = skipspaces;
3292             }
3293             skipspaces = 0;
3294             if (s <= send)
3295                 *fpc++ = FF_NEWLINE;
3296             if (noblank) {
3297                 *fpc++ = FF_BLANK;
3298                 if (repeat)
3299                     arg = fpc - linepc + 1;
3300                 else
3301                     arg = 0;
3302                 *fpc++ = arg;
3303             }
3304             if (s < send) {
3305                 linepc = fpc;
3306                 *fpc++ = FF_LINEMARK;
3307                 noblank = repeat = FALSE;
3308                 base = s;
3309             }
3310             else
3311                 s++;
3312             continue;
3313
3314         case '@':
3315         case '^':
3316             ischop = s[-1] == '^';
3317
3318             if (postspace) {
3319                 *fpc++ = FF_SPACE;
3320                 postspace = FALSE;
3321             }
3322             arg = (s - base) - 1;
3323             if (arg) {
3324                 *fpc++ = FF_LITERAL;
3325                 *fpc++ = arg;
3326             }
3327
3328             base = s - 1;
3329             *fpc++ = FF_FETCH;
3330             if (*s == '*') {
3331                 s++;
3332                 *fpc++ = 0;
3333                 *fpc++ = FF_LINEGLOB;
3334             }
3335             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3336                 arg = ischop ? 512 : 0;
3337                 base = s - 1;
3338                 while (*s == '#')
3339                     s++;
3340                 if (*s == '.') {
3341                     char *f;
3342                     s++;
3343                     f = s;
3344                     while (*s == '#')
3345                         s++;
3346                     arg |= 256 + (s - f);
3347                 }
3348                 *fpc++ = s - base;              /* fieldsize for FETCH */
3349                 *fpc++ = FF_DECIMAL;
3350                 *fpc++ = arg;
3351             }
3352             else {
3353                 I32 prespace = 0;
3354                 bool ismore = FALSE;
3355
3356                 if (*s == '>') {
3357                     while (*++s == '>') ;
3358                     prespace = FF_SPACE;
3359                 }
3360                 else if (*s == '|') {
3361                     while (*++s == '|') ;
3362                     prespace = FF_HALFSPACE;
3363                     postspace = TRUE;
3364                 }
3365                 else {
3366                     if (*s == '<')
3367                         while (*++s == '<') ;
3368                     postspace = TRUE;
3369                 }
3370                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3371                     s += 3;
3372                     ismore = TRUE;
3373                 }
3374                 *fpc++ = s - base;              /* fieldsize for FETCH */
3375
3376                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3377
3378                 if (prespace)
3379                     *fpc++ = prespace;
3380                 *fpc++ = FF_ITEM;
3381                 if (ismore)
3382                     *fpc++ = FF_MORE;
3383                 if (ischop)
3384                     *fpc++ = FF_CHOP;
3385             }
3386             base = s;
3387             skipspaces = 0;
3388             continue;
3389         }
3390     }
3391     *fpc++ = FF_END;
3392
3393     arg = fpc - fops;
3394     { /* need to jump to the next word */
3395         int z;
3396         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3397         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3398         s = SvPVX(sv) + SvCUR(sv) + z;
3399     }
3400     Copy(fops, s, arg, U16);
3401     Safefree(fops);
3402     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3403     SvCOMPILED_on(sv);
3404 }
3405
3406 /*
3407  * The rest of this file was derived from source code contributed
3408  * by Tom Horsley.
3409  *
3410  * NOTE: this code was derived from Tom Horsley's qsort replacement
3411  * and should not be confused with the original code.
3412  */
3413
3414 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3415
3416    Permission granted to distribute under the same terms as perl which are
3417    (briefly):
3418
3419     This program is free software; you can redistribute it and/or modify
3420     it under the terms of either:
3421
3422         a) the GNU General Public License as published by the Free
3423         Software Foundation; either version 1, or (at your option) any
3424         later version, or
3425
3426         b) the "Artistic License" which comes with this Kit.
3427
3428    Details on the perl license can be found in the perl source code which
3429    may be located via the www.perl.com web page.
3430
3431    This is the most wonderfulest possible qsort I can come up with (and
3432    still be mostly portable) My (limited) tests indicate it consistently
3433    does about 20% fewer calls to compare than does the qsort in the Visual
3434    C++ library, other vendors may vary.
3435
3436    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3437    others I invented myself (or more likely re-invented since they seemed
3438    pretty obvious once I watched the algorithm operate for a while).
3439
3440    Most of this code was written while watching the Marlins sweep the Giants
3441    in the 1997 National League Playoffs - no Braves fans allowed to use this
3442    code (just kidding :-).
3443
3444    I realize that if I wanted to be true to the perl tradition, the only
3445    comment in this file would be something like:
3446
3447    ...they shuffled back towards the rear of the line. 'No, not at the
3448    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3449
3450    However, I really needed to violate that tradition just so I could keep
3451    track of what happens myself, not to mention some poor fool trying to
3452    understand this years from now :-).
3453 */
3454
3455 /* ********************************************************** Configuration */
3456
3457 #ifndef QSORT_ORDER_GUESS
3458 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3459 #endif
3460
3461 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3462    future processing - a good max upper bound is log base 2 of memory size
3463    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3464    safely be smaller than that since the program is taking up some space and
3465    most operating systems only let you grab some subset of contiguous
3466    memory (not to mention that you are normally sorting data larger than
3467    1 byte element size :-).
3468 */
3469 #ifndef QSORT_MAX_STACK
3470 #define QSORT_MAX_STACK 32
3471 #endif
3472
3473 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3474    Anything bigger and we use qsort. If you make this too small, the qsort
3475    will probably break (or become less efficient), because it doesn't expect
3476    the middle element of a partition to be the same as the right or left -
3477    you have been warned).
3478 */
3479 #ifndef QSORT_BREAK_EVEN
3480 #define QSORT_BREAK_EVEN 6
3481 #endif
3482
3483 /* ************************************************************* Data Types */
3484
3485 /* hold left and right index values of a partition waiting to be sorted (the
3486    partition includes both left and right - right is NOT one past the end or
3487    anything like that).
3488 */
3489 struct partition_stack_entry {
3490    int left;
3491    int right;
3492 #ifdef QSORT_ORDER_GUESS
3493    int qsort_break_even;
3494 #endif
3495 };
3496
3497 /* ******************************************************* Shorthand Macros */
3498
3499 /* Note that these macros will be used from inside the qsort function where
3500    we happen to know that the variable 'elt_size' contains the size of an
3501    array element and the variable 'temp' points to enough space to hold a
3502    temp element and the variable 'array' points to the array being sorted
3503    and 'compare' is the pointer to the compare routine.
3504
3505    Also note that there are very many highly architecture specific ways
3506    these might be sped up, but this is simply the most generally portable
3507    code I could think of.
3508 */
3509
3510 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3511 */
3512 #define qsort_cmp(elt1, elt2) \
3513    ((*compare)(aTHXo_ array[elt1], array[elt2]))
3514
3515 #ifdef QSORT_ORDER_GUESS
3516 #define QSORT_NOTICE_SWAP swapped++;
3517 #else
3518 #define QSORT_NOTICE_SWAP
3519 #endif
3520
3521 /* swaps contents of array elements elt1, elt2.
3522 */
3523 #define qsort_swap(elt1, elt2) \
3524    STMT_START { \
3525       QSORT_NOTICE_SWAP \
3526       temp = array[elt1]; \
3527       array[elt1] = array[elt2]; \
3528       array[elt2] = temp; \
3529    } STMT_END
3530
3531 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3532    elt3 and elt3 gets elt1.
3533 */
3534 #define qsort_rotate(elt1, elt2, elt3) \
3535    STMT_START { \
3536       QSORT_NOTICE_SWAP \
3537       temp = array[elt1]; \
3538       array[elt1] = array[elt2]; \
3539       array[elt2] = array[elt3]; \
3540       array[elt3] = temp; \
3541    } STMT_END
3542
3543 /* ************************************************************ Debug stuff */
3544
3545 #ifdef QSORT_DEBUG
3546
3547 static void
3548 break_here()
3549 {
3550    return; /* good place to set a breakpoint */
3551 }
3552
3553 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3554
3555 static void
3556 doqsort_all_asserts(
3557    void * array,
3558    size_t num_elts,
3559    size_t elt_size,
3560    int (*compare)(const void * elt1, const void * elt2),
3561    int pc_left, int pc_right, int u_left, int u_right)
3562 {
3563    int i;
3564
3565    qsort_assert(pc_left <= pc_right);
3566    qsort_assert(u_right < pc_left);
3567    qsort_assert(pc_right < u_left);
3568    for (i = u_right + 1; i < pc_left; ++i) {
3569       qsort_assert(qsort_cmp(i, pc_left) < 0);
3570    }
3571    for (i = pc_left; i < pc_right; ++i) {
3572       qsort_assert(qsort_cmp(i, pc_right) == 0);
3573    }
3574    for (i = pc_right + 1; i < u_left; ++i) {
3575       qsort_assert(qsort_cmp(pc_right, i) < 0);
3576    }
3577 }
3578
3579 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3580    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3581                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3582
3583 #else
3584
3585 #define qsort_assert(t) ((void)0)
3586
3587 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3588
3589 #endif
3590
3591 /* ****************************************************************** qsort */
3592
3593 STATIC void
3594 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3595 {
3596    register SV * temp;
3597
3598    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3599    int next_stack_entry = 0;
3600
3601    int part_left;
3602    int part_right;
3603 #ifdef QSORT_ORDER_GUESS
3604    int qsort_break_even;
3605    int swapped;
3606 #endif
3607
3608    /* Make sure we actually have work to do.
3609    */
3610    if (num_elts <= 1) {
3611       return;
3612    }
3613
3614    /* Setup the initial partition definition and fall into the sorting loop
3615    */
3616    part_left = 0;
3617    part_right = (int)(num_elts - 1);
3618 #ifdef QSORT_ORDER_GUESS
3619    qsort_break_even = QSORT_BREAK_EVEN;
3620 #else
3621 #define qsort_break_even QSORT_BREAK_EVEN
3622 #endif
3623    for ( ; ; ) {
3624       if ((part_right - part_left) >= qsort_break_even) {
3625          /* OK, this is gonna get hairy, so lets try to document all the
3626             concepts and abbreviations and variables and what they keep
3627             track of:
3628
3629             pc: pivot chunk - the set of array elements we accumulate in the
3630                 middle of the partition, all equal in value to the original
3631                 pivot element selected. The pc is defined by:
3632
3633                 pc_left - the leftmost array index of the pc
3634                 pc_right - the rightmost array index of the pc
3635
3636                 we start with pc_left == pc_right and only one element
3637                 in the pivot chunk (but it can grow during the scan).
3638
3639             u:  uncompared elements - the set of elements in the partition
3640                 we have not yet compared to the pivot value. There are two
3641                 uncompared sets during the scan - one to the left of the pc
3642                 and one to the right.
3643
3644                 u_right - the rightmost index of the left side's uncompared set
3645                 u_left - the leftmost index of the right side's uncompared set
3646
3647                 The leftmost index of the left sides's uncompared set
3648                 doesn't need its own variable because it is always defined
3649                 by the leftmost edge of the whole partition (part_left). The
3650                 same goes for the rightmost edge of the right partition
3651                 (part_right).
3652
3653                 We know there are no uncompared elements on the left once we
3654                 get u_right < part_left and no uncompared elements on the
3655                 right once u_left > part_right. When both these conditions
3656                 are met, we have completed the scan of the partition.
3657
3658                 Any elements which are between the pivot chunk and the
3659                 uncompared elements should be less than the pivot value on
3660                 the left side and greater than the pivot value on the right
3661                 side (in fact, the goal of the whole algorithm is to arrange
3662                 for that to be true and make the groups of less-than and
3663                 greater-then elements into new partitions to sort again).
3664
3665             As you marvel at the complexity of the code and wonder why it
3666             has to be so confusing. Consider some of the things this level
3667             of confusion brings:
3668
3669             Once I do a compare, I squeeze every ounce of juice out of it. I
3670             never do compare calls I don't have to do, and I certainly never
3671             do redundant calls.
3672
3673             I also never swap any elements unless I can prove there is a
3674             good reason. Many sort algorithms will swap a known value with
3675             an uncompared value just to get things in the right place (or
3676             avoid complexity :-), but that uncompared value, once it gets
3677             compared, may then have to be swapped again. A lot of the
3678             complexity of this code is due to the fact that it never swaps
3679             anything except compared values, and it only swaps them when the
3680             compare shows they are out of position.
3681          */
3682          int pc_left, pc_right;
3683          int u_right, u_left;
3684
3685          int s;
3686
3687          pc_left = ((part_left + part_right) / 2);
3688          pc_right = pc_left;
3689          u_right = pc_left - 1;
3690          u_left = pc_right + 1;
3691
3692          /* Qsort works best when the pivot value is also the median value
3693             in the partition (unfortunately you can't find the median value
3694             without first sorting :-), so to give the algorithm a helping
3695             hand, we pick 3 elements and sort them and use the median value
3696             of that tiny set as the pivot value.
3697
3698             Some versions of qsort like to use the left middle and right as
3699             the 3 elements to sort so they can insure the ends of the
3700             partition will contain values which will stop the scan in the
3701             compare loop, but when you have to call an arbitrarily complex
3702             routine to do a compare, its really better to just keep track of
3703             array index values to know when you hit the edge of the
3704             partition and avoid the extra compare. An even better reason to
3705             avoid using a compare call is the fact that you can drop off the
3706             edge of the array if someone foolishly provides you with an
3707             unstable compare function that doesn't always provide consistent
3708             results.
3709
3710             So, since it is simpler for us to compare the three adjacent
3711             elements in the middle of the partition, those are the ones we
3712             pick here (conveniently pointed at by u_right, pc_left, and
3713             u_left). The values of the left, center, and right elements
3714             are refered to as l c and r in the following comments.
3715          */
3716
3717 #ifdef QSORT_ORDER_GUESS
3718          swapped = 0;
3719 #endif
3720          s = qsort_cmp(u_right, pc_left);
3721          if (s < 0) {
3722             /* l < c */
3723             s = qsort_cmp(pc_left, u_left);
3724             /* if l < c, c < r - already in order - nothing to do */
3725             if (s == 0) {
3726                /* l < c, c == r - already in order, pc grows */
3727                ++pc_right;
3728                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3729             } else if (s > 0) {
3730                /* l < c, c > r - need to know more */
3731                s = qsort_cmp(u_right, u_left);
3732                if (s < 0) {
3733                   /* l < c, c > r, l < r - swap c & r to get ordered */
3734                   qsort_swap(pc_left, u_left);
3735                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3736                } else if (s == 0) {
3737                   /* l < c, c > r, l == r - swap c&r, grow pc */
3738                   qsort_swap(pc_left, u_left);
3739                   --pc_left;
3740                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3741                } else {
3742                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3743                   qsort_rotate(pc_left, u_right, u_left);
3744                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3745                }
3746             }
3747          } else if (s == 0) {
3748             /* l == c */
3749             s = qsort_cmp(pc_left, u_left);
3750             if (s < 0) {
3751                /* l == c, c < r - already in order, grow pc */
3752                --pc_left;
3753                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3754             } else if (s == 0) {
3755                /* l == c, c == r - already in order, grow pc both ways */
3756                --pc_left;
3757                ++pc_right;
3758                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3759             } else {
3760                /* l == c, c > r - swap l & r, grow pc */
3761                qsort_swap(u_right, u_left);
3762                ++pc_right;
3763                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3764             }
3765          } else {
3766             /* l > c */
3767             s = qsort_cmp(pc_left, u_left);
3768             if (s < 0) {
3769                /* l > c, c < r - need to know more */
3770                s = qsort_cmp(u_right, u_left);
3771                if (s < 0) {
3772                   /* l > c, c < r, l < r - swap l & c to get ordered */
3773                   qsort_swap(u_right, pc_left);
3774                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3775                } else if (s == 0) {
3776                   /* l > c, c < r, l == r - swap l & c, grow pc */
3777                   qsort_swap(u_right, pc_left);
3778                   ++pc_right;
3779                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3780                } else {
3781                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3782                   qsort_rotate(u_right, pc_left, u_left);
3783                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3784                }
3785             } else if (s == 0) {
3786                /* l > c, c == r - swap ends, grow pc */
3787                qsort_swap(u_right, u_left);
3788                --pc_left;
3789                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3790             } else {
3791                /* l > c, c > r - swap ends to get in order */
3792                qsort_swap(u_right, u_left);
3793                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3794             }
3795          }
3796          /* We now know the 3 middle elements have been compared and
3797             arranged in the desired order, so we can shrink the uncompared
3798             sets on both sides
3799          */
3800          --u_right;
3801          ++u_left;
3802          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3803
3804          /* The above massive nested if was the simple part :-). We now have
3805             the middle 3 elements ordered and we need to scan through the
3806             uncompared sets on either side, swapping elements that are on
3807             the wrong side or simply shuffling equal elements around to get
3808             all equal elements into the pivot chunk.
3809          */
3810
3811          for ( ; ; ) {
3812             int still_work_on_left;
3813             int still_work_on_right;
3814
3815             /* Scan the uncompared values on the left. If I find a value
3816                equal to the pivot value, move it over so it is adjacent to
3817                the pivot chunk and expand the pivot chunk. If I find a value
3818                less than the pivot value, then just leave it - its already
3819                on the correct side of the partition. If I find a greater
3820                value, then stop the scan.
3821             */
3822             while (still_work_on_left = (u_right >= part_left)) {
3823                s = qsort_cmp(u_right, pc_left);
3824                if (s < 0) {
3825                   --u_right;
3826                } else if (s == 0) {
3827                   --pc_left;
3828                   if (pc_left != u_right) {
3829                      qsort_swap(u_right, pc_left);
3830                   }
3831                   --u_right;
3832                } else {
3833                   break;
3834                }
3835                qsort_assert(u_right < pc_left);
3836                qsort_assert(pc_left <= pc_right);
3837                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3838                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3839             }
3840
3841             /* Do a mirror image scan of uncompared values on the right
3842             */
3843             while (still_work_on_right = (u_left <= part_right)) {
3844                s = qsort_cmp(pc_right, u_left);
3845                if (s < 0) {
3846                   ++u_left;
3847                } else if (s == 0) {
3848                   ++pc_right;
3849                   if (pc_right != u_left) {
3850                      qsort_swap(pc_right, u_left);
3851                   }
3852                   ++u_left;
3853                } else {
3854                   break;
3855                }
3856                qsort_assert(u_left > pc_right);
3857                qsort_assert(pc_left <= pc_right);
3858                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3859                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3860             }
3861
3862             if (still_work_on_left) {
3863                /* I know I have a value on the left side which needs to be
3864                   on the right side, but I need to know more to decide
3865                   exactly the best thing to do with it.
3866                */
3867                if (still_work_on_right) {
3868                   /* I know I have values on both side which are out of
3869                      position. This is a big win because I kill two birds
3870                      with one swap (so to speak). I can advance the
3871                      uncompared pointers on both sides after swapping both
3872                      of them into the right place.
3873                   */
3874                   qsort_swap(u_right, u_left);
3875                   --u_right;
3876                   ++u_left;
3877                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3878                } else {
3879                   /* I have an out of position value on the left, but the
3880                      right is fully scanned, so I "slide" the pivot chunk
3881                      and any less-than values left one to make room for the
3882                      greater value over on the right. If the out of position
3883                      value is immediately adjacent to the pivot chunk (there
3884                      are no less-than values), I can do that with a swap,
3885                      otherwise, I have to rotate one of the less than values
3886                      into the former position of the out of position value
3887                      and the right end of the pivot chunk into the left end
3888                      (got all that?).
3889                   */
3890                   --pc_left;
3891                   if (pc_left == u_right) {
3892                      qsort_swap(u_right, pc_right);
3893                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3894                   } else {
3895                      qsort_rotate(u_right, pc_left, pc_right);
3896                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3897                   }
3898                   --pc_right;
3899                   --u_right;
3900                }
3901             } else if (still_work_on_right) {
3902                /* Mirror image of complex case above: I have an out of
3903                   position value on the right, but the left is fully
3904                   scanned, so I need to shuffle things around to make room
3905                   for the right value on the left.
3906                */
3907                ++pc_right;
3908                if (pc_right == u_left) {
3909                   qsort_swap(u_left, pc_left);
3910                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3911                } else {
3912                   qsort_rotate(pc_right, pc_left, u_left);
3913                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3914                }
3915                ++pc_left;
3916                ++u_left;
3917             } else {
3918                /* No more scanning required on either side of partition,
3919                   break out of loop and figure out next set of partitions
3920                */
3921                break;
3922             }
3923          }
3924
3925          /* The elements in the pivot chunk are now in the right place. They
3926             will never move or be compared again. All I have to do is decide
3927             what to do with the stuff to the left and right of the pivot
3928             chunk.
3929
3930             Notes on the QSORT_ORDER_GUESS ifdef code:
3931
3932             1. If I just built these partitions without swapping any (or
3933                very many) elements, there is a chance that the elements are
3934                already ordered properly (being properly ordered will
3935                certainly result in no swapping, but the converse can't be
3936                proved :-).
3937
3938             2. A (properly written) insertion sort will run faster on
3939                already ordered data than qsort will.
3940
3941             3. Perhaps there is some way to make a good guess about
3942                switching to an insertion sort earlier than partition size 6
3943                (for instance - we could save the partition size on the stack
3944                and increase the size each time we find we didn't swap, thus
3945                switching to insertion sort earlier for partitions with a
3946                history of not swapping).
3947
3948             4. Naturally, if I just switch right away, it will make
3949                artificial benchmarks with pure ascending (or descending)
3950                data look really good, but is that a good reason in general?
3951                Hard to say...
3952          */
3953
3954 #ifdef QSORT_ORDER_GUESS
3955          if (swapped < 3) {
3956 #if QSORT_ORDER_GUESS == 1
3957             qsort_break_even = (part_right - part_left) + 1;
3958 #endif
3959 #if QSORT_ORDER_GUESS == 2
3960             qsort_break_even *= 2;
3961 #endif
3962 #if QSORT_ORDER_GUESS == 3
3963             int prev_break = qsort_break_even;
3964             qsort_break_even *= qsort_break_even;
3965             if (qsort_break_even < prev_break) {
3966                qsort_break_even = (part_right - part_left) + 1;
3967             }
3968 #endif
3969          } else {
3970             qsort_break_even = QSORT_BREAK_EVEN;
3971          }
3972 #endif
3973
3974          if (part_left < pc_left) {
3975             /* There are elements on the left which need more processing.
3976                Check the right as well before deciding what to do.
3977             */
3978             if (pc_right < part_right) {
3979                /* We have two partitions to be sorted. Stack the biggest one
3980                   and process the smallest one on the next iteration. This
3981                   minimizes the stack height by insuring that any additional
3982                   stack entries must come from the smallest partition which
3983                   (because it is smallest) will have the fewest
3984                   opportunities to generate additional stack entries.
3985                */
3986                if ((part_right - pc_right) > (pc_left - part_left)) {
3987                   /* stack the right partition, process the left */
3988                   partition_stack[next_stack_entry].left = pc_right + 1;
3989                   partition_stack[next_stack_entry].right = part_right;
3990 #ifdef QSORT_ORDER_GUESS
3991                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3992 #endif
3993                   part_right = pc_left - 1;
3994                } else {
3995                   /* stack the left partition, process the right */
3996                   partition_stack[next_stack_entry].left = part_left;
3997                   partition_stack[next_stack_entry].right = pc_left - 1;
3998 #ifdef QSORT_ORDER_GUESS
3999                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4000 #endif
4001                   part_left = pc_right + 1;
4002                }
4003                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4004                ++next_stack_entry;
4005             } else {
4006                /* The elements on the left are the only remaining elements
4007                   that need sorting, arrange for them to be processed as the
4008                   next partition.
4009                */
4010                part_right = pc_left - 1;
4011             }
4012          } else if (pc_right < part_right) {
4013             /* There is only one chunk on the right to be sorted, make it
4014                the new partition and loop back around.
4015             */
4016             part_left = pc_right + 1;
4017          } else {
4018             /* This whole partition wound up in the pivot chunk, so
4019                we need to get a new partition off the stack.
4020             */
4021             if (next_stack_entry == 0) {
4022                /* the stack is empty - we are done */
4023                break;
4024             }
4025             --next_stack_entry;
4026             part_left = partition_stack[next_stack_entry].left;
4027             part_right = partition_stack[next_stack_entry].right;
4028 #ifdef QSORT_ORDER_GUESS
4029             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4030 #endif
4031          }
4032       } else {
4033          /* This partition is too small to fool with qsort complexity, just
4034             do an ordinary insertion sort to minimize overhead.
4035          */
4036          int i;
4037          /* Assume 1st element is in right place already, and start checking
4038             at 2nd element to see where it should be inserted.
4039          */
4040          for (i = part_left + 1; i <= part_right; ++i) {
4041             int j;
4042             /* Scan (backwards - just in case 'i' is already in right place)
4043                through the elements already sorted to see if the ith element
4044                belongs ahead of one of them.
4045             */
4046             for (j = i - 1; j >= part_left; --j) {
4047                if (qsort_cmp(i, j) >= 0) {
4048                   /* i belongs right after j
4049                   */
4050                   break;
4051                }
4052             }
4053             ++j;
4054             if (j != i) {
4055                /* Looks like we really need to move some things
4056                */
4057                int k;
4058                temp = array[i];
4059                for (k = i - 1; k >= j; --k)
4060                   array[k + 1] = array[k];
4061                array[j] = temp;
4062             }
4063          }
4064
4065          /* That partition is now sorted, grab the next one, or get out
4066             of the loop if there aren't any more.
4067          */
4068
4069          if (next_stack_entry == 0) {
4070             /* the stack is empty - we are done */
4071             break;
4072          }
4073          --next_stack_entry;
4074          part_left = partition_stack[next_stack_entry].left;
4075          part_right = partition_stack[next_stack_entry].right;
4076 #ifdef QSORT_ORDER_GUESS
4077          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4078 #endif
4079       }
4080    }
4081
4082    /* Believe it or not, the array is sorted at this point! */
4083 }
4084
4085
4086 #ifdef PERL_OBJECT
4087 #define NO_XSLOCKS
4088 #undef this
4089 #define this pPerl
4090 #include "XSUB.h"
4091 #endif
4092
4093
4094 static I32
4095 sortcv(pTHXo_ SV *a, SV *b)
4096 {
4097     dTHR;
4098     I32 oldsaveix = PL_savestack_ix;
4099     I32 oldscopeix = PL_scopestack_ix;
4100     I32 result;
4101     GvSV(PL_firstgv) = a;
4102     GvSV(PL_secondgv) = b;
4103     PL_stack_sp = PL_stack_base;
4104     PL_op = PL_sortcop;
4105     CALLRUNOPS(aTHX);
4106     if (PL_stack_sp != PL_stack_base + 1)
4107         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4108     if (!SvNIOKp(*PL_stack_sp))
4109         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4110     result = SvIV(*PL_stack_sp);
4111     while (PL_scopestack_ix > oldscopeix) {
4112         LEAVE;
4113     }
4114     leave_scope(oldsaveix);
4115     return result;
4116 }
4117
4118
4119 static I32
4120 sv_ncmp(pTHXo_ SV *a, SV *b)
4121 {
4122     NV nv1 = SvNV(a);
4123     NV nv2 = SvNV(b);
4124     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4125 }
4126
4127 static I32
4128 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4129 {
4130     IV iv1 = SvIV(a);
4131     IV iv2 = SvIV(b);
4132     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4133 }
4134 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4135           *svp = Nullsv;                                \
4136           if (PL_amagic_generation) { \
4137             if (SvAMAGIC(left)||SvAMAGIC(right))\
4138                 *svp = amagic_call(left, \
4139                                    right, \
4140                                    CAT2(meth,_amg), \
4141                                    0); \
4142           } \
4143         } STMT_END
4144
4145 static I32
4146 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4147 {
4148     SV *tmpsv;
4149     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4150     if (tmpsv) {
4151         NV d;
4152
4153         if (SvIOK(tmpsv)) {
4154             I32 i = SvIVX(tmpsv);
4155             if (i > 0)
4156                return 1;
4157             return i? -1 : 0;
4158         }
4159         d = SvNV(tmpsv);
4160         if (d > 0)
4161            return 1;
4162         return d? -1 : 0;
4163      }
4164      return sv_ncmp(aTHXo_ a, b);
4165 }
4166
4167 static I32
4168 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4169 {
4170     SV *tmpsv;
4171     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4172     if (tmpsv) {
4173         NV d;
4174
4175         if (SvIOK(tmpsv)) {
4176             I32 i = SvIVX(tmpsv);
4177             if (i > 0)
4178                return 1;
4179             return i? -1 : 0;
4180         }
4181         d = SvNV(tmpsv);
4182         if (d > 0)
4183            return 1;
4184         return d? -1 : 0;
4185     }
4186     return sv_i_ncmp(aTHXo_ a, b);
4187 }
4188
4189 static I32
4190 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4191 {
4192     SV *tmpsv;
4193     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4194     if (tmpsv) {
4195         NV d;
4196
4197         if (SvIOK(tmpsv)) {
4198             I32 i = SvIVX(tmpsv);
4199             if (i > 0)
4200                return 1;
4201             return i? -1 : 0;
4202         }
4203         d = SvNV(tmpsv);
4204         if (d > 0)
4205            return 1;
4206         return d? -1 : 0;
4207     }
4208     return sv_cmp(str1, str2);
4209 }
4210
4211 static I32
4212 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4213 {
4214     SV *tmpsv;
4215     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4216     if (tmpsv) {
4217         NV d;
4218
4219         if (SvIOK(tmpsv)) {
4220             I32 i = SvIVX(tmpsv);
4221             if (i > 0)
4222                return 1;
4223             return i? -1 : 0;
4224         }
4225         d = SvNV(tmpsv);
4226         if (d > 0)
4227            return 1;
4228         return d? -1 : 0;
4229     }
4230     return sv_cmp_locale(str1, str2);
4231 }
4232
4233 static I32
4234 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4235 {
4236     SV *datasv = FILTER_DATA(idx);
4237     int filter_has_file = IoLINES(datasv);
4238     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4239     SV *filter_state = (SV *)IoTOP_GV(datasv);
4240     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4241     int len = 0;
4242
4243     /* I was having segfault trouble under Linux 2.2.5 after a
4244        parse error occured.  (Had to hack around it with a test
4245        for PL_error_count == 0.)  Solaris doesn't segfault --
4246        not sure where the trouble is yet.  XXX */
4247
4248     if (filter_has_file) {
4249         len = FILTER_READ(idx+1, buf_sv, maxlen);
4250     }
4251
4252     if (filter_sub && len >= 0) {
4253         djSP;
4254         int count;
4255
4256         ENTER;
4257         SAVE_DEFSV;
4258         SAVETMPS;
4259         EXTEND(SP, 2);
4260
4261         DEFSV = buf_sv;
4262         PUSHMARK(SP);
4263         PUSHs(sv_2mortal(newSViv(maxlen)));
4264         if (filter_state) {
4265             PUSHs(filter_state);
4266         }
4267         PUTBACK;
4268         count = call_sv(filter_sub, G_SCALAR);
4269         SPAGAIN;
4270
4271         if (count > 0) {
4272             SV *out = POPs;
4273             if (SvOK(out)) {
4274                 len = SvIV(out);
4275             }
4276         }
4277
4278         PUTBACK;
4279         FREETMPS;
4280         LEAVE;
4281     }
4282
4283     if (len <= 0) {
4284         IoLINES(datasv) = 0;
4285         if (filter_child_proc) {
4286             SvREFCNT_dec(filter_child_proc);
4287             IoFMT_GV(datasv) = Nullgv;
4288         }
4289         if (filter_state) {
4290             SvREFCNT_dec(filter_state);
4291             IoTOP_GV(datasv) = Nullgv;
4292         }
4293         if (filter_sub) {
4294             SvREFCNT_dec(filter_sub);
4295             IoBOTTOM_GV(datasv) = Nullgv;
4296         }
4297         filter_del(run_user_filter);
4298     }
4299
4300     return len;
4301 }
4302
4303 #ifdef PERL_OBJECT
4304
4305 static I32
4306 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4307 {
4308     return sv_cmp_locale(str1, str2);
4309 }
4310
4311 static I32
4312 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4313 {
4314     return sv_cmp(str1, str2);
4315 }
4316
4317 #endif /* PERL_OBJECT */