pp_ctl.c

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