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