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