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