pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (c) 1991-2000, 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 tbuf[TYPE_DIGITS(long) + 12 + 10];
2574     char *tmpbuf = tbuf;
2575     char *safestr;
2576
2577     ENTER;
2578     lex_start(sv);
2579     SAVETMPS;
2580     /* switch to eval mode */
2581
2582     if (PL_curcop == &PL_compiling) {
2583         SAVECOPSTASH(&PL_compiling);
2584         CopSTASH_set(&PL_compiling, PL_curstash);
2585     }
2586     SAVECOPFILE(&PL_compiling);
2587     SAVECOPLINE(&PL_compiling);
2588     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2589         SV *sv = sv_newmortal();
2590         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2591                        code, (unsigned long)++PL_evalseq,
2592                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2593         tmpbuf = SvPVX(sv);
2594     }
2595     else
2596         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2597     CopFILE_set(&PL_compiling, tmpbuf+2);
2598     CopLINE_set(&PL_compiling, 1);
2599     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2600        deleting the eval's FILEGV from the stash before gv_check() runs
2601        (i.e. before run-time proper). To work around the coredump that
2602        ensues, we always turn GvMULTI_on for any globals that were
2603        introduced within evals. See force_ident(). GSAR 96-10-12 */
2604     safestr = savepv(tmpbuf);
2605     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2606     SAVEHINTS();
2607 #ifdef OP_IN_REGISTER
2608     PL_opsave = op;
2609 #else
2610     SAVEVPTR(PL_op);
2611 #endif
2612     PL_hints = 0;
2613
2614     PL_op = &dummy;
2615     PL_op->op_type = OP_ENTEREVAL;
2616     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2617     PUSHBLOCK(cx, CXt_EVAL, SP);
2618     PUSHEVAL(cx, 0, Nullgv);
2619     rop = doeval(G_SCALAR, startop);
2620     POPBLOCK(cx,PL_curpm);
2621     POPEVAL(cx);
2622
2623     (*startop)->op_type = OP_NULL;
2624     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2625     lex_end();
2626     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2627     LEAVE;
2628     if (PL_curcop == &PL_compiling)
2629         PL_compiling.op_private = PL_hints;
2630 #ifdef OP_IN_REGISTER
2631     op = PL_opsave;
2632 #endif
2633     return rop;
2634 }
2635
2636 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2637 STATIC OP *
2638 S_doeval(pTHX_ int gimme, OP** startop)
2639 {
2640     dSP;
2641     OP *saveop = PL_op;
2642     CV *caller;
2643     AV* comppadlist;
2644     I32 i;
2645
2646     PL_in_eval = EVAL_INEVAL;
2647
2648     PUSHMARK(SP);
2649
2650     /* set up a scratch pad */
2651
2652     SAVEI32(PL_padix);
2653     SAVEVPTR(PL_curpad);
2654     SAVESPTR(PL_comppad);
2655     SAVESPTR(PL_comppad_name);
2656     SAVEI32(PL_comppad_name_fill);
2657     SAVEI32(PL_min_intro_pending);
2658     SAVEI32(PL_max_intro_pending);
2659
2660     caller = PL_compcv;
2661     for (i = cxstack_ix - 1; i >= 0; i--) {
2662         PERL_CONTEXT *cx = &cxstack[i];
2663         if (CxTYPE(cx) == CXt_EVAL)
2664             break;
2665         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2666             caller = cx->blk_sub.cv;
2667             break;
2668         }
2669     }
2670
2671     SAVESPTR(PL_compcv);
2672     PL_compcv = (CV*)NEWSV(1104,0);
2673     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2674     CvEVAL_on(PL_compcv);
2675 #ifdef USE_THREADS
2676     CvOWNER(PL_compcv) = 0;
2677     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2678     MUTEX_INIT(CvMUTEXP(PL_compcv));
2679 #endif /* USE_THREADS */
2680
2681     PL_comppad = newAV();
2682     av_push(PL_comppad, Nullsv);
2683     PL_curpad = AvARRAY(PL_comppad);
2684     PL_comppad_name = newAV();
2685     PL_comppad_name_fill = 0;
2686     PL_min_intro_pending = 0;
2687     PL_padix = 0;
2688 #ifdef USE_THREADS
2689     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2690     PL_curpad[0] = (SV*)newAV();
2691     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2692 #endif /* USE_THREADS */
2693
2694     comppadlist = newAV();
2695     AvREAL_off(comppadlist);
2696     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2697     av_store(comppadlist, 1, (SV*)PL_comppad);
2698     CvPADLIST(PL_compcv) = comppadlist;
2699
2700     if (!saveop || saveop->op_type != OP_REQUIRE)
2701         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2702
2703     SAVEFREESV(PL_compcv);
2704
2705     /* make sure we compile in the right package */
2706
2707     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2708         SAVESPTR(PL_curstash);
2709         PL_curstash = CopSTASH(PL_curcop);
2710     }
2711     SAVESPTR(PL_beginav);
2712     PL_beginav = newAV();
2713     SAVEFREESV(PL_beginav);
2714
2715     /* try to compile it */
2716
2717     PL_eval_root = Nullop;
2718     PL_error_count = 0;
2719     PL_curcop = &PL_compiling;
2720     PL_curcop->cop_arybase = 0;
2721     SvREFCNT_dec(PL_rs);
2722     PL_rs = newSVpvn("\n", 1);
2723     if (saveop && saveop->op_flags & OPf_SPECIAL)
2724         PL_in_eval |= EVAL_KEEPERR;
2725     else
2726         sv_setpv(ERRSV,"");
2727     if (yyparse() || PL_error_count || !PL_eval_root) {
2728         SV **newsp;
2729         I32 gimme;
2730         PERL_CONTEXT *cx;
2731         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2732         STRLEN n_a;
2733
2734         PL_op = saveop;
2735         if (PL_eval_root) {
2736             op_free(PL_eval_root);
2737             PL_eval_root = Nullop;
2738         }
2739         SP = PL_stack_base + POPMARK;           /* pop original mark */
2740         if (!startop) {
2741             POPBLOCK(cx,PL_curpm);
2742             POPEVAL(cx);
2743             pop_return();
2744         }
2745         lex_end();
2746         LEAVE;
2747         if (optype == OP_REQUIRE) {
2748             char* msg = SvPVx(ERRSV, n_a);
2749             DIE(aTHX_ "%sCompilation failed in require",
2750                 *msg ? msg : "Unknown error\n");
2751         }
2752         else if (startop) {
2753             char* msg = SvPVx(ERRSV, n_a);
2754
2755             POPBLOCK(cx,PL_curpm);
2756             POPEVAL(cx);
2757             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2758                        (*msg ? msg : "Unknown error\n"));
2759         }
2760         SvREFCNT_dec(PL_rs);
2761         PL_rs = SvREFCNT_inc(PL_nrs);
2762 #ifdef USE_THREADS
2763         MUTEX_LOCK(&PL_eval_mutex);
2764         PL_eval_owner = 0;
2765         COND_SIGNAL(&PL_eval_cond);
2766         MUTEX_UNLOCK(&PL_eval_mutex);
2767 #endif /* USE_THREADS */
2768         RETPUSHUNDEF;
2769     }
2770     SvREFCNT_dec(PL_rs);
2771     PL_rs = SvREFCNT_inc(PL_nrs);
2772     CopLINE_set(&PL_compiling, 0);
2773     if (startop) {
2774         *startop = PL_eval_root;
2775         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2776         CvOUTSIDE(PL_compcv) = Nullcv;
2777     } else
2778         SAVEFREEOP(PL_eval_root);
2779     if (gimme & G_VOID)
2780         scalarvoid(PL_eval_root);
2781     else if (gimme & G_ARRAY)
2782         list(PL_eval_root);
2783     else
2784         scalar(PL_eval_root);
2785
2786     DEBUG_x(dump_eval());
2787
2788     /* Register with debugger: */
2789     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2790         CV *cv = get_cv("DB::postponed", FALSE);
2791         if (cv) {
2792             dSP;
2793             PUSHMARK(SP);
2794             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2795             PUTBACK;
2796             call_sv((SV*)cv, G_DISCARD);
2797         }
2798     }
2799
2800     /* compiled okay, so do it */
2801
2802     CvDEPTH(PL_compcv) = 1;
2803     SP = PL_stack_base + POPMARK;               /* pop original mark */
2804     PL_op = saveop;                     /* The caller may need it. */
2805 #ifdef USE_THREADS
2806     MUTEX_LOCK(&PL_eval_mutex);
2807     PL_eval_owner = 0;
2808     COND_SIGNAL(&PL_eval_cond);
2809     MUTEX_UNLOCK(&PL_eval_mutex);
2810 #endif /* USE_THREADS */
2811
2812     RETURNOP(PL_eval_start);
2813 }
2814
2815 STATIC PerlIO *
2816 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2817 {
2818     STRLEN namelen = strlen(name);
2819     PerlIO *fp;
2820
2821     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2822         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2823         char *pmc = SvPV_nolen(pmcsv);
2824         Stat_t pmstat;
2825         Stat_t pmcstat;
2826         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2827             fp = PerlIO_open(name, mode);
2828         }
2829         else {
2830             if (PerlLIO_stat(name, &pmstat) < 0 ||
2831                 pmstat.st_mtime < pmcstat.st_mtime)
2832             {
2833                 fp = PerlIO_open(pmc, mode);
2834             }
2835             else {
2836                 fp = PerlIO_open(name, mode);
2837             }
2838         }
2839         SvREFCNT_dec(pmcsv);
2840     }
2841     else {
2842         fp = PerlIO_open(name, mode);
2843     }
2844     return fp;
2845 }
2846
2847 PP(pp_require)
2848 {
2849     djSP;
2850     register PERL_CONTEXT *cx;
2851     SV *sv;
2852     char *name;
2853     STRLEN len;
2854     char *tryname;
2855     SV *namesv = Nullsv;
2856     SV** svp;
2857     I32 gimme = G_SCALAR;
2858     PerlIO *tryrsfp = 0;
2859     STRLEN n_a;
2860     int filter_has_file = 0;
2861     GV *filter_child_proc = 0;
2862     SV *filter_state = 0;
2863     SV *filter_sub = 0;
2864
2865     sv = POPs;
2866     if (SvNIOKp(sv)) {
2867         UV rev, ver, sver;
2868         if (SvPOKp(sv)) {               /* require v5.6.1 */
2869             I32 len;
2870             U8 *s = (U8*)SvPVX(sv);
2871             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2872             if (s < end) {
2873                 rev = utf8_to_uv(s, &len);
2874                 s += len;
2875                 if (s < end) {
2876                     ver = utf8_to_uv(s, &len);
2877                     s += len;
2878                     if (s < end)
2879                         sver = utf8_to_uv(s, &len);
2880                     else
2881                         sver = 0;
2882                 }
2883                 else
2884                     ver = 0;
2885             }
2886             else
2887                 rev = 0;
2888             if (PERL_REVISION < rev
2889                 || (PERL_REVISION == rev
2890                     && (PERL_VERSION < ver
2891                         || (PERL_VERSION == ver
2892                             && PERL_SUBVERSION < sver))))
2893             {
2894                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2895                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2896                     PERL_VERSION, PERL_SUBVERSION);
2897             }
2898         }
2899         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2900             NV n = SvNV(sv);
2901             rev = (UV)n;
2902             ver = (UV)((n-rev)*1000);
2903             sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
2904
2905             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2906                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2907                 + 0.00000099 < SvNV(sv))
2908             {
2909                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2910                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2911                     PERL_VERSION, PERL_SUBVERSION);
2912             }
2913         }
2914         RETPUSHYES;
2915     }
2916     name = SvPV(sv, len);
2917     if (!(name && len > 0 && *name))
2918         DIE(aTHX_ "Null filename used");
2919     TAINT_PROPER("require");
2920     if (PL_op->op_type == OP_REQUIRE &&
2921       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2922       *svp != &PL_sv_undef)
2923         RETPUSHYES;
2924
2925     /* prepare to compile file */
2926
2927     if (PERL_FILE_IS_ABSOLUTE(name)
2928         || (*name == '.' && (name[1] == '/' ||
2929                              (name[1] == '.' && name[2] == '/'))))
2930     {
2931         tryname = name;
2932         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2933     }
2934     else {
2935         AV *ar = GvAVn(PL_incgv);
2936         I32 i;
2937 #ifdef VMS
2938         char *unixname;
2939         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2940 #endif
2941         {
2942             namesv = NEWSV(806, 0);
2943             for (i = 0; i <= AvFILL(ar); i++) {
2944                 SV *dirsv = *av_fetch(ar, i, TRUE);
2945
2946                 if (SvROK(dirsv)) {
2947                     int count;
2948                     SV *loader = dirsv;
2949
2950                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2951                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2952                     }
2953
2954                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2955                                    PTR2UV(SvANY(loader)), name);
2956                     tryname = SvPVX(namesv);
2957                     tryrsfp = 0;
2958
2959                     ENTER;
2960                     SAVETMPS;
2961                     EXTEND(SP, 2);
2962
2963                     PUSHMARK(SP);
2964                     PUSHs(dirsv);
2965                     PUSHs(sv);
2966                     PUTBACK;
2967                     count = call_sv(loader, G_ARRAY);
2968                     SPAGAIN;
2969
2970                     if (count > 0) {
2971                         int i = 0;
2972                         SV *arg;
2973
2974                         SP -= count - 1;
2975                         arg = SP[i++];
2976
2977                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2978                             arg = SvRV(arg);
2979                         }
2980
2981                         if (SvTYPE(arg) == SVt_PVGV) {
2982                             IO *io = GvIO((GV *)arg);
2983
2984                             ++filter_has_file;
2985
2986                             if (io) {
2987                                 tryrsfp = IoIFP(io);
2988                                 if (IoTYPE(io) == '|') {
2989                                     /* reading from a child process doesn't
2990                                        nest -- when returning from reading
2991                                        the inner module, the outer one is
2992                                        unreadable (closed?)  I've tried to
2993                                        save the gv to manage the lifespan of
2994                                        the pipe, but this didn't help. XXX */
2995                                     filter_child_proc = (GV *)arg;
2996                                     (void)SvREFCNT_inc(filter_child_proc);
2997                                 }
2998                                 else {
2999                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3000                                         PerlIO_close(IoOFP(io));
3001                                     }
3002                                     IoIFP(io) = Nullfp;
3003                                     IoOFP(io) = Nullfp;
3004                                 }
3005                             }
3006
3007                             if (i < count) {
3008                                 arg = SP[i++];
3009                             }
3010                         }
3011
3012                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3013                             filter_sub = arg;
3014                             (void)SvREFCNT_inc(filter_sub);
3015
3016                             if (i < count) {
3017                                 filter_state = SP[i];
3018                                 (void)SvREFCNT_inc(filter_state);
3019                             }
3020
3021                             if (tryrsfp == 0) {
3022                                 tryrsfp = PerlIO_open("/dev/null",
3023                                                       PERL_SCRIPT_MODE);
3024                             }
3025                         }
3026                     }
3027
3028                     PUTBACK;
3029                     FREETMPS;
3030                     LEAVE;
3031
3032                     if (tryrsfp) {
3033                         break;
3034                     }
3035
3036                     filter_has_file = 0;
3037                     if (filter_child_proc) {
3038                         SvREFCNT_dec(filter_child_proc);
3039                         filter_child_proc = 0;
3040                     }
3041                     if (filter_state) {
3042                         SvREFCNT_dec(filter_state);
3043                         filter_state = 0;
3044                     }
3045                     if (filter_sub) {
3046                         SvREFCNT_dec(filter_sub);
3047                         filter_sub = 0;
3048                     }
3049                 }
3050                 else {
3051                     char *dir = SvPVx(dirsv, n_a);
3052 #ifdef VMS
3053                     char *unixdir;
3054                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3055                         continue;
3056                     sv_setpv(namesv, unixdir);
3057                     sv_catpv(namesv, unixname);
3058 #else
3059                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3060 #endif
3061                     TAINT_PROPER("require");
3062                     tryname = SvPVX(namesv);
3063                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3064                     if (tryrsfp) {
3065                         if (tryname[0] == '.' && tryname[1] == '/')
3066                             tryname += 2;
3067                         break;
3068                     }
3069                 }
3070             }
3071         }
3072     }
3073     SAVECOPFILE(&PL_compiling);
3074     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3075     SvREFCNT_dec(namesv);
3076     if (!tryrsfp) {
3077         if (PL_op->op_type == OP_REQUIRE) {
3078             char *msgstr = name;
3079             if (namesv) {                       /* did we lookup @INC? */
3080                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3081                 SV *dirmsgsv = NEWSV(0, 0);
3082                 AV *ar = GvAVn(PL_incgv);
3083                 I32 i;
3084                 sv_catpvn(msg, " in @INC", 8);
3085                 if (instr(SvPVX(msg), ".h "))
3086                     sv_catpv(msg, " (change .h to .ph maybe?)");
3087                 if (instr(SvPVX(msg), ".ph "))
3088                     sv_catpv(msg, " (did you run h2ph?)");
3089                 sv_catpv(msg, " (@INC contains:");
3090                 for (i = 0; i <= AvFILL(ar); i++) {
3091                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3092                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3093                     sv_catsv(msg, dirmsgsv);
3094                 }
3095                 sv_catpvn(msg, ")", 1);
3096                 SvREFCNT_dec(dirmsgsv);
3097                 msgstr = SvPV_nolen(msg);
3098             }
3099             DIE(aTHX_ "Can't locate %s", msgstr);
3100         }
3101
3102         RETPUSHUNDEF;
3103     }
3104     else
3105         SETERRNO(0, SS$_NORMAL);
3106
3107     /* Assume success here to prevent recursive requirement. */
3108     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3109                    newSVpv(CopFILE(&PL_compiling), 0), 0 );
3110
3111     ENTER;
3112     SAVETMPS;
3113     lex_start(sv_2mortal(newSVpvn("",0)));
3114     SAVEGENERICSV(PL_rsfp_filters);
3115     PL_rsfp_filters = Nullav;
3116
3117     PL_rsfp = tryrsfp;
3118     SAVEHINTS();
3119     PL_hints = 0;
3120     SAVESPTR(PL_compiling.cop_warnings);
3121     if (PL_dowarn & G_WARN_ALL_ON)
3122         PL_compiling.cop_warnings = WARN_ALL ;
3123     else if (PL_dowarn & G_WARN_ALL_OFF)
3124         PL_compiling.cop_warnings = WARN_NONE ;
3125     else
3126         PL_compiling.cop_warnings = WARN_STD ;
3127
3128     if (filter_sub || filter_child_proc) {
3129         SV *datasv = filter_add(run_user_filter, Nullsv);
3130         IoLINES(datasv) = filter_has_file;
3131         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3132         IoTOP_GV(datasv) = (GV *)filter_state;
3133         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3134     }
3135
3136     /* switch to eval mode */
3137     push_return(PL_op->op_next);
3138     PUSHBLOCK(cx, CXt_EVAL, SP);
3139     PUSHEVAL(cx, name, Nullgv);
3140
3141     SAVECOPLINE(&PL_compiling);
3142     CopLINE_set(&PL_compiling, 0);
3143
3144     PUTBACK;
3145 #ifdef USE_THREADS
3146     MUTEX_LOCK(&PL_eval_mutex);
3147     if (PL_eval_owner && PL_eval_owner != thr)
3148         while (PL_eval_owner)
3149             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3150     PL_eval_owner = thr;
3151     MUTEX_UNLOCK(&PL_eval_mutex);
3152 #endif /* USE_THREADS */
3153     return DOCATCH(doeval(G_SCALAR, NULL));
3154 }
3155
3156 PP(pp_dofile)
3157 {
3158     return pp_require();
3159 }
3160
3161 PP(pp_entereval)
3162 {
3163     djSP;
3164     register PERL_CONTEXT *cx;
3165     dPOPss;
3166     I32 gimme = GIMME_V, was = PL_sub_generation;
3167     char tbuf[TYPE_DIGITS(long) + 12];
3168     char *tmpbuf = tbuf;
3169     char *safestr;
3170     STRLEN len;
3171     OP *ret;
3172
3173     if (!SvPV(sv,len) || !len)
3174         RETPUSHUNDEF;
3175     TAINT_PROPER("eval");
3176
3177     ENTER;
3178     lex_start(sv);
3179     SAVETMPS;
3180
3181     /* switch to eval mode */
3182
3183     SAVECOPFILE(&PL_compiling);
3184     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3185         SV *sv = sv_newmortal();
3186         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3187                        (unsigned long)++PL_evalseq,
3188                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3189         tmpbuf = SvPVX(sv);
3190     }
3191     else
3192         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3193     CopFILE_set(&PL_compiling, tmpbuf+2);
3194     CopLINE_set(&PL_compiling, 1);
3195     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3196        deleting the eval's FILEGV from the stash before gv_check() runs
3197        (i.e. before run-time proper). To work around the coredump that
3198        ensues, we always turn GvMULTI_on for any globals that were
3199        introduced within evals. See force_ident(). GSAR 96-10-12 */
3200     safestr = savepv(tmpbuf);
3201     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3202     SAVEHINTS();
3203     PL_hints = PL_op->op_targ;
3204     SAVESPTR(PL_compiling.cop_warnings);
3205     if (!specialWARN(PL_compiling.cop_warnings)) {
3206         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3207         SAVEFREESV(PL_compiling.cop_warnings) ;
3208     }
3209
3210     push_return(PL_op->op_next);
3211     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3212     PUSHEVAL(cx, 0, Nullgv);
3213
3214     /* prepare to compile string */
3215
3216     if (PERLDB_LINE && PL_curstash != PL_debstash)
3217         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3218     PUTBACK;
3219 #ifdef USE_THREADS
3220     MUTEX_LOCK(&PL_eval_mutex);
3221     if (PL_eval_owner && PL_eval_owner != thr)
3222         while (PL_eval_owner)
3223             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3224     PL_eval_owner = thr;
3225     MUTEX_UNLOCK(&PL_eval_mutex);
3226 #endif /* USE_THREADS */
3227     ret = doeval(gimme, NULL);
3228     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3229         && ret != PL_op->op_next) {     /* Successive compilation. */
3230         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3231     }
3232     return DOCATCH(ret);
3233 }
3234
3235 PP(pp_leaveeval)
3236 {
3237     djSP;
3238     register SV **mark;
3239     SV **newsp;
3240     PMOP *newpm;
3241     I32 gimme;
3242     register PERL_CONTEXT *cx;
3243     OP *retop;
3244     U8 save_flags = PL_op -> op_flags;
3245     I32 optype;
3246
3247     POPBLOCK(cx,newpm);
3248     POPEVAL(cx);
3249     retop = pop_return();
3250
3251     TAINT_NOT;
3252     if (gimme == G_VOID)
3253         MARK = newsp;
3254     else if (gimme == G_SCALAR) {
3255         MARK = newsp + 1;
3256         if (MARK <= SP) {
3257             if (SvFLAGS(TOPs) & SVs_TEMP)
3258                 *MARK = TOPs;
3259             else
3260                 *MARK = sv_mortalcopy(TOPs);
3261         }
3262         else {
3263             MEXTEND(mark,0);
3264             *MARK = &PL_sv_undef;
3265         }
3266         SP = MARK;
3267     }
3268     else {
3269         /* in case LEAVE wipes old return values */
3270         for (mark = newsp + 1; mark <= SP; mark++) {
3271             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3272                 *mark = sv_mortalcopy(*mark);
3273                 TAINT_NOT;      /* Each item is independent */
3274             }
3275         }
3276     }
3277     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3278
3279     if (AvFILLp(PL_comppad_name) >= 0)
3280         free_closures();
3281
3282 #ifdef DEBUGGING
3283     assert(CvDEPTH(PL_compcv) == 1);
3284 #endif
3285     CvDEPTH(PL_compcv) = 0;
3286     lex_end();
3287
3288     if (optype == OP_REQUIRE &&
3289         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3290     {
3291         /* Unassume the success we assumed earlier. */
3292         char *name = cx->blk_eval.old_name;
3293         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3294         retop = Perl_die(aTHX_ "%s did not return a true value", name);
3295         /* die_where() did LEAVE, or we won't be here */
3296     }
3297     else {
3298         LEAVE;
3299         if (!(save_flags & OPf_SPECIAL))
3300             sv_setpv(ERRSV,"");
3301     }
3302
3303     RETURNOP(retop);
3304 }
3305
3306 PP(pp_entertry)
3307 {
3308     djSP;
3309     register PERL_CONTEXT *cx;
3310     I32 gimme = GIMME_V;
3311
3312     ENTER;
3313     SAVETMPS;
3314
3315     push_return(cLOGOP->op_other->op_next);
3316     PUSHBLOCK(cx, CXt_EVAL, SP);
3317     PUSHEVAL(cx, 0, 0);
3318     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3319
3320     PL_in_eval = EVAL_INEVAL;
3321     sv_setpv(ERRSV,"");
3322     PUTBACK;
3323     return DOCATCH(PL_op->op_next);
3324 }
3325
3326 PP(pp_leavetry)
3327 {
3328     djSP;
3329     register SV **mark;
3330     SV **newsp;
3331     PMOP *newpm;
3332     I32 gimme;
3333     register PERL_CONTEXT *cx;
3334     I32 optype;
3335
3336     POPBLOCK(cx,newpm);
3337     POPEVAL(cx);
3338     pop_return();
3339
3340     TAINT_NOT;
3341     if (gimme == G_VOID)
3342         SP = newsp;
3343     else if (gimme == G_SCALAR) {
3344         MARK = newsp + 1;
3345         if (MARK <= SP) {
3346             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3347                 *MARK = TOPs;
3348             else
3349                 *MARK = sv_mortalcopy(TOPs);
3350         }
3351         else {
3352             MEXTEND(mark,0);
3353             *MARK = &PL_sv_undef;
3354         }
3355         SP = MARK;
3356     }
3357     else {
3358         /* in case LEAVE wipes old return values */
3359         for (mark = newsp + 1; mark <= SP; mark++) {
3360             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3361                 *mark = sv_mortalcopy(*mark);
3362                 TAINT_NOT;      /* Each item is independent */
3363             }
3364         }
3365     }
3366     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3367
3368     LEAVE;
3369     sv_setpv(ERRSV,"");
3370     RETURN;
3371 }
3372
3373 STATIC void
3374 S_doparseform(pTHX_ SV *sv)
3375 {
3376     STRLEN len;
3377     register char *s = SvPV_force(sv, len);
3378     register char *send = s + len;
3379     register char *base;
3380     register I32 skipspaces = 0;
3381     bool noblank;
3382     bool repeat;
3383     bool postspace = FALSE;
3384     U16 *fops;
3385     register U16 *fpc;
3386     U16 *linepc;
3387     register I32 arg;
3388     bool ischop;
3389
3390     if (len == 0)
3391         Perl_croak(aTHX_ "Null picture in formline");
3392
3393     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3394     fpc = fops;
3395
3396     if (s < send) {
3397         linepc = fpc;
3398         *fpc++ = FF_LINEMARK;
3399         noblank = repeat = FALSE;
3400         base = s;
3401     }
3402
3403     while (s <= send) {
3404         switch (*s++) {
3405         default:
3406             skipspaces = 0;
3407             continue;
3408
3409         case '~':
3410             if (*s == '~') {
3411                 repeat = TRUE;
3412                 *s = ' ';
3413             }
3414             noblank = TRUE;
3415             s[-1] = ' ';
3416             /* FALL THROUGH */
3417         case ' ': case '\t':
3418             skipspaces++;
3419             continue;
3420
3421         case '\n': case 0:
3422             arg = s - base;
3423             skipspaces++;
3424             arg -= skipspaces;
3425             if (arg) {
3426                 if (postspace)
3427                     *fpc++ = FF_SPACE;
3428                 *fpc++ = FF_LITERAL;
3429                 *fpc++ = arg;
3430             }
3431             postspace = FALSE;
3432             if (s <= send)
3433                 skipspaces--;
3434             if (skipspaces) {
3435                 *fpc++ = FF_SKIP;
3436                 *fpc++ = skipspaces;
3437             }
3438             skipspaces = 0;
3439             if (s <= send)
3440                 *fpc++ = FF_NEWLINE;
3441             if (noblank) {
3442                 *fpc++ = FF_BLANK;
3443                 if (repeat)
3444                     arg = fpc - linepc + 1;
3445                 else
3446                     arg = 0;
3447                 *fpc++ = arg;
3448             }
3449             if (s < send) {
3450                 linepc = fpc;
3451                 *fpc++ = FF_LINEMARK;
3452                 noblank = repeat = FALSE;
3453                 base = s;
3454             }
3455             else
3456                 s++;
3457             continue;
3458
3459         case '@':
3460         case '^':
3461             ischop = s[-1] == '^';
3462
3463             if (postspace) {
3464                 *fpc++ = FF_SPACE;
3465                 postspace = FALSE;
3466             }
3467             arg = (s - base) - 1;
3468             if (arg) {
3469                 *fpc++ = FF_LITERAL;
3470                 *fpc++ = arg;
3471             }
3472
3473             base = s - 1;
3474             *fpc++ = FF_FETCH;
3475             if (*s == '*') {
3476                 s++;
3477                 *fpc++ = 0;
3478                 *fpc++ = FF_LINEGLOB;
3479             }
3480             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3481                 arg = ischop ? 512 : 0;
3482                 base = s - 1;
3483                 while (*s == '#')
3484                     s++;
3485                 if (*s == '.') {
3486                     char *f;
3487                     s++;
3488                     f = s;
3489                     while (*s == '#')
3490                         s++;
3491                     arg |= 256 + (s - f);
3492                 }
3493                 *fpc++ = s - base;              /* fieldsize for FETCH */
3494                 *fpc++ = FF_DECIMAL;
3495                 *fpc++ = arg;
3496             }
3497             else {
3498                 I32 prespace = 0;
3499                 bool ismore = FALSE;
3500
3501                 if (*s == '>') {
3502                     while (*++s == '>') ;
3503                     prespace = FF_SPACE;
3504                 }
3505                 else if (*s == '|') {
3506                     while (*++s == '|') ;
3507                     prespace = FF_HALFSPACE;
3508                     postspace = TRUE;
3509                 }
3510                 else {
3511                     if (*s == '<')
3512                         while (*++s == '<') ;
3513                     postspace = TRUE;
3514                 }
3515                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3516                     s += 3;
3517                     ismore = TRUE;
3518                 }
3519                 *fpc++ = s - base;              /* fieldsize for FETCH */
3520
3521                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3522
3523                 if (prespace)
3524                     *fpc++ = prespace;
3525                 *fpc++ = FF_ITEM;
3526                 if (ismore)
3527                     *fpc++ = FF_MORE;
3528                 if (ischop)
3529                     *fpc++ = FF_CHOP;
3530             }
3531             base = s;
3532             skipspaces = 0;
3533             continue;
3534         }
3535     }
3536     *fpc++ = FF_END;
3537
3538     arg = fpc - fops;
3539     { /* need to jump to the next word */
3540         int z;
3541         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3542         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3543         s = SvPVX(sv) + SvCUR(sv) + z;
3544     }
3545     Copy(fops, s, arg, U16);
3546     Safefree(fops);
3547     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3548     SvCOMPILED_on(sv);
3549 }
3550
3551 /*
3552  * The rest of this file was derived from source code contributed
3553  * by Tom Horsley.
3554  *
3555  * NOTE: this code was derived from Tom Horsley's qsort replacement
3556  * and should not be confused with the original code.
3557  */
3558
3559 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3560
3561    Permission granted to distribute under the same terms as perl which are
3562    (briefly):
3563
3564     This program is free software; you can redistribute it and/or modify
3565     it under the terms of either:
3566
3567         a) the GNU General Public License as published by the Free
3568         Software Foundation; either version 1, or (at your option) any
3569         later version, or
3570
3571         b) the "Artistic License" which comes with this Kit.
3572
3573    Details on the perl license can be found in the perl source code which
3574    may be located via the www.perl.com web page.
3575
3576    This is the most wonderfulest possible qsort I can come up with (and
3577    still be mostly portable) My (limited) tests indicate it consistently
3578    does about 20% fewer calls to compare than does the qsort in the Visual
3579    C++ library, other vendors may vary.
3580
3581    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3582    others I invented myself (or more likely re-invented since they seemed
3583    pretty obvious once I watched the algorithm operate for a while).
3584
3585    Most of this code was written while watching the Marlins sweep the Giants
3586    in the 1997 National League Playoffs - no Braves fans allowed to use this
3587    code (just kidding :-).
3588
3589    I realize that if I wanted to be true to the perl tradition, the only
3590    comment in this file would be something like:
3591
3592    ...they shuffled back towards the rear of the line. 'No, not at the
3593    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3594
3595    However, I really needed to violate that tradition just so I could keep
3596    track of what happens myself, not to mention some poor fool trying to
3597    understand this years from now :-).
3598 */
3599
3600 /* ********************************************************** Configuration */
3601
3602 #ifndef QSORT_ORDER_GUESS
3603 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3604 #endif
3605
3606 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3607    future processing - a good max upper bound is log base 2 of memory size
3608    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3609    safely be smaller than that since the program is taking up some space and
3610    most operating systems only let you grab some subset of contiguous
3611    memory (not to mention that you are normally sorting data larger than
3612    1 byte element size :-).
3613 */
3614 #ifndef QSORT_MAX_STACK
3615 #define QSORT_MAX_STACK 32
3616 #endif
3617
3618 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3619    Anything bigger and we use qsort. If you make this too small, the qsort
3620    will probably break (or become less efficient), because it doesn't expect
3621    the middle element of a partition to be the same as the right or left -
3622    you have been warned).
3623 */
3624 #ifndef QSORT_BREAK_EVEN
3625 #define QSORT_BREAK_EVEN 6
3626 #endif
3627
3628 /* ************************************************************* Data Types */
3629
3630 /* hold left and right index values of a partition waiting to be sorted (the
3631    partition includes both left and right - right is NOT one past the end or
3632    anything like that).
3633 */
3634 struct partition_stack_entry {
3635    int left;
3636    int right;
3637 #ifdef QSORT_ORDER_GUESS
3638    int qsort_break_even;
3639 #endif
3640 };
3641
3642 /* ******************************************************* Shorthand Macros */
3643
3644 /* Note that these macros will be used from inside the qsort function where
3645    we happen to know that the variable 'elt_size' contains the size of an
3646    array element and the variable 'temp' points to enough space to hold a
3647    temp element and the variable 'array' points to the array being sorted
3648    and 'compare' is the pointer to the compare routine.
3649
3650    Also note that there are very many highly architecture specific ways
3651    these might be sped up, but this is simply the most generally portable
3652    code I could think of.
3653 */
3654
3655 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3656 */
3657 #define qsort_cmp(elt1, elt2) \
3658    ((*compare)(aTHXo_ array[elt1], array[elt2]))
3659
3660 #ifdef QSORT_ORDER_GUESS
3661 #define QSORT_NOTICE_SWAP swapped++;
3662 #else
3663 #define QSORT_NOTICE_SWAP
3664 #endif
3665
3666 /* swaps contents of array elements elt1, elt2.
3667 */
3668 #define qsort_swap(elt1, elt2) \
3669    STMT_START { \
3670       QSORT_NOTICE_SWAP \
3671       temp = array[elt1]; \
3672       array[elt1] = array[elt2]; \
3673       array[elt2] = temp; \
3674    } STMT_END
3675
3676 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3677    elt3 and elt3 gets elt1.
3678 */
3679 #define qsort_rotate(elt1, elt2, elt3) \
3680    STMT_START { \
3681       QSORT_NOTICE_SWAP \
3682       temp = array[elt1]; \
3683       array[elt1] = array[elt2]; \
3684       array[elt2] = array[elt3]; \
3685       array[elt3] = temp; \
3686    } STMT_END
3687
3688 /* ************************************************************ Debug stuff */
3689
3690 #ifdef QSORT_DEBUG
3691
3692 static void
3693 break_here()
3694 {
3695    return; /* good place to set a breakpoint */
3696 }
3697
3698 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3699
3700 static void
3701 doqsort_all_asserts(
3702    void * array,
3703    size_t num_elts,
3704    size_t elt_size,
3705    int (*compare)(const void * elt1, const void * elt2),
3706    int pc_left, int pc_right, int u_left, int u_right)
3707 {
3708    int i;
3709
3710    qsort_assert(pc_left <= pc_right);
3711    qsort_assert(u_right < pc_left);
3712    qsort_assert(pc_right < u_left);
3713    for (i = u_right + 1; i < pc_left; ++i) {
3714       qsort_assert(qsort_cmp(i, pc_left) < 0);
3715    }
3716    for (i = pc_left; i < pc_right; ++i) {
3717       qsort_assert(qsort_cmp(i, pc_right) == 0);
3718    }
3719    for (i = pc_right + 1; i < u_left; ++i) {
3720       qsort_assert(qsort_cmp(pc_right, i) < 0);
3721    }
3722 }
3723
3724 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3725    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3726                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3727
3728 #else
3729
3730 #define qsort_assert(t) ((void)0)
3731
3732 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3733
3734 #endif
3735
3736 /* ****************************************************************** qsort */
3737
3738 STATIC void
3739 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3740 {
3741    register SV * temp;
3742
3743    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3744    int next_stack_entry = 0;
3745
3746    int part_left;
3747    int part_right;
3748 #ifdef QSORT_ORDER_GUESS
3749    int qsort_break_even;
3750    int swapped;
3751 #endif
3752
3753    /* Make sure we actually have work to do.
3754    */
3755    if (num_elts <= 1) {
3756       return;
3757    }
3758
3759    /* Setup the initial partition definition and fall into the sorting loop
3760    */
3761    part_left = 0;
3762    part_right = (int)(num_elts - 1);
3763 #ifdef QSORT_ORDER_GUESS
3764    qsort_break_even = QSORT_BREAK_EVEN;
3765 #else
3766 #define qsort_break_even QSORT_BREAK_EVEN
3767 #endif
3768    for ( ; ; ) {
3769       if ((part_right - part_left) >= qsort_break_even) {
3770          /* OK, this is gonna get hairy, so lets try to document all the
3771             concepts and abbreviations and variables and what they keep
3772             track of:
3773
3774             pc: pivot chunk - the set of array elements we accumulate in the
3775                 middle of the partition, all equal in value to the original
3776                 pivot element selected. The pc is defined by:
3777
3778                 pc_left - the leftmost array index of the pc
3779                 pc_right - the rightmost array index of the pc
3780
3781                 we start with pc_left == pc_right and only one element
3782                 in the pivot chunk (but it can grow during the scan).
3783
3784             u:  uncompared elements - the set of elements in the partition
3785                 we have not yet compared to the pivot value. There are two
3786                 uncompared sets during the scan - one to the left of the pc
3787                 and one to the right.
3788
3789                 u_right - the rightmost index of the left side's uncompared set
3790                 u_left - the leftmost index of the right side's uncompared set
3791
3792                 The leftmost index of the left sides's uncompared set
3793                 doesn't need its own variable because it is always defined
3794                 by the leftmost edge of the whole partition (part_left). The
3795                 same goes for the rightmost edge of the right partition
3796                 (part_right).
3797
3798                 We know there are no uncompared elements on the left once we
3799                 get u_right < part_left and no uncompared elements on the
3800                 right once u_left > part_right. When both these conditions
3801                 are met, we have completed the scan of the partition.
3802
3803                 Any elements which are between the pivot chunk and the
3804                 uncompared elements should be less than the pivot value on
3805                 the left side and greater than the pivot value on the right
3806                 side (in fact, the goal of the whole algorithm is to arrange
3807                 for that to be true and make the groups of less-than and
3808                 greater-then elements into new partitions to sort again).
3809
3810             As you marvel at the complexity of the code and wonder why it
3811             has to be so confusing. Consider some of the things this level
3812             of confusion brings:
3813
3814             Once I do a compare, I squeeze every ounce of juice out of it. I
3815             never do compare calls I don't have to do, and I certainly never
3816             do redundant calls.
3817
3818             I also never swap any elements unless I can prove there is a
3819             good reason. Many sort algorithms will swap a known value with
3820             an uncompared value just to get things in the right place (or
3821             avoid complexity :-), but that uncompared value, once it gets
3822             compared, may then have to be swapped again. A lot of the
3823             complexity of this code is due to the fact that it never swaps
3824             anything except compared values, and it only swaps them when the
3825             compare shows they are out of position.
3826          */
3827          int pc_left, pc_right;
3828          int u_right, u_left;
3829
3830          int s;
3831
3832          pc_left = ((part_left + part_right) / 2);
3833          pc_right = pc_left;
3834          u_right = pc_left - 1;
3835          u_left = pc_right + 1;
3836
3837          /* Qsort works best when the pivot value is also the median value
3838             in the partition (unfortunately you can't find the median value
3839             without first sorting :-), so to give the algorithm a helping
3840             hand, we pick 3 elements and sort them and use the median value
3841             of that tiny set as the pivot value.
3842
3843             Some versions of qsort like to use the left middle and right as
3844             the 3 elements to sort so they can insure the ends of the
3845             partition will contain values which will stop the scan in the
3846             compare loop, but when you have to call an arbitrarily complex
3847             routine to do a compare, its really better to just keep track of
3848             array index values to know when you hit the edge of the
3849             partition and avoid the extra compare. An even better reason to
3850             avoid using a compare call is the fact that you can drop off the
3851             edge of the array if someone foolishly provides you with an
3852             unstable compare function that doesn't always provide consistent
3853             results.
3854
3855             So, since it is simpler for us to compare the three adjacent
3856             elements in the middle of the partition, those are the ones we
3857             pick here (conveniently pointed at by u_right, pc_left, and
3858             u_left). The values of the left, center, and right elements
3859             are refered to as l c and r in the following comments.
3860          */
3861
3862 #ifdef QSORT_ORDER_GUESS
3863          swapped = 0;
3864 #endif
3865          s = qsort_cmp(u_right, pc_left);
3866          if (s < 0) {
3867             /* l < c */
3868             s = qsort_cmp(pc_left, u_left);
3869             /* if l < c, c < r - already in order - nothing to do */
3870             if (s == 0) {
3871                /* l < c, c == r - already in order, pc grows */
3872                ++pc_right;
3873                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3874             } else if (s > 0) {
3875                /* l < c, c > r - need to know more */
3876                s = qsort_cmp(u_right, u_left);
3877                if (s < 0) {
3878                   /* l < c, c > r, l < r - swap c & r to get ordered */
3879                   qsort_swap(pc_left, u_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, l == r - swap c&r, grow pc */
3883                   qsort_swap(pc_left, u_left);
3884                   --pc_left;
3885                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3886                } else {
3887                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3888                   qsort_rotate(pc_left, u_right, u_left);
3889                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3890                }
3891             }
3892          } else if (s == 0) {
3893             /* l == c */
3894             s = qsort_cmp(pc_left, u_left);
3895             if (s < 0) {
3896                /* l == c, c < r - already in order, grow pc */
3897                --pc_left;
3898                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3899             } else if (s == 0) {
3900                /* l == c, c == r - already in order, grow pc both ways */
3901                --pc_left;
3902                ++pc_right;
3903                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3904             } else {
3905                /* l == c, c > r - swap l & r, grow pc */
3906                qsort_swap(u_right, u_left);
3907                ++pc_right;
3908                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3909             }
3910          } else {
3911             /* l > c */
3912             s = qsort_cmp(pc_left, u_left);
3913             if (s < 0) {
3914                /* l > c, c < r - need to know more */
3915                s = qsort_cmp(u_right, u_left);
3916                if (s < 0) {
3917                   /* l > c, c < r, l < r - swap l & c to get ordered */
3918                   qsort_swap(u_right, pc_left);
3919                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3920                } else if (s == 0) {
3921                   /* l > c, c < r, l == r - swap l & c, grow pc */
3922                   qsort_swap(u_right, pc_left);
3923                   ++pc_right;
3924                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3925                } else {
3926                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3927                   qsort_rotate(u_right, pc_left, u_left);
3928                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3929                }
3930             } else if (s == 0) {
3931                /* l > c, c == r - swap ends, grow pc */
3932                qsort_swap(u_right, u_left);
3933                --pc_left;
3934                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3935             } else {
3936                /* l > c, c > r - swap ends to get in order */
3937                qsort_swap(u_right, u_left);
3938                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3939             }
3940          }
3941          /* We now know the 3 middle elements have been compared and
3942             arranged in the desired order, so we can shrink the uncompared
3943             sets on both sides
3944          */
3945          --u_right;
3946          ++u_left;
3947          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3948
3949          /* The above massive nested if was the simple part :-). We now have
3950             the middle 3 elements ordered and we need to scan through the
3951             uncompared sets on either side, swapping elements that are on
3952             the wrong side or simply shuffling equal elements around to get
3953             all equal elements into the pivot chunk.
3954          */
3955
3956          for ( ; ; ) {
3957             int still_work_on_left;
3958             int still_work_on_right;
3959
3960             /* Scan the uncompared values on the left. If I find a value
3961                equal to the pivot value, move it over so it is adjacent to
3962                the pivot chunk and expand the pivot chunk. If I find a value
3963                less than the pivot value, then just leave it - its already
3964                on the correct side of the partition. If I find a greater
3965                value, then stop the scan.
3966             */
3967             while (still_work_on_left = (u_right >= part_left)) {
3968                s = qsort_cmp(u_right, pc_left);
3969                if (s < 0) {
3970                   --u_right;
3971                } else if (s == 0) {
3972                   --pc_left;
3973                   if (pc_left != u_right) {
3974                      qsort_swap(u_right, pc_left);
3975                   }
3976                   --u_right;
3977                } else {
3978                   break;
3979                }
3980                qsort_assert(u_right < pc_left);
3981                qsort_assert(pc_left <= pc_right);
3982                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3983                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3984             }
3985
3986             /* Do a mirror image scan of uncompared values on the right
3987             */
3988             while (still_work_on_right = (u_left <= part_right)) {
3989                s = qsort_cmp(pc_right, u_left);
3990                if (s < 0) {
3991                   ++u_left;
3992                } else if (s == 0) {
3993                   ++pc_right;
3994                   if (pc_right != u_left) {
3995                      qsort_swap(pc_right, u_left);
3996                   }
3997                   ++u_left;
3998                } else {
3999                   break;
4000                }
4001                qsort_assert(u_left > pc_right);
4002                qsort_assert(pc_left <= pc_right);
4003                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4004                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4005             }
4006
4007             if (still_work_on_left) {
4008                /* I know I have a value on the left side which needs to be
4009                   on the right side, but I need to know more to decide
4010                   exactly the best thing to do with it.
4011                */
4012                if (still_work_on_right) {
4013                   /* I know I have values on both side which are out of
4014                      position. This is a big win because I kill two birds
4015                      with one swap (so to speak). I can advance the
4016                      uncompared pointers on both sides after swapping both
4017                      of them into the right place.
4018                   */
4019                   qsort_swap(u_right, u_left);
4020                   --u_right;
4021                   ++u_left;
4022                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4023                } else {
4024                   /* I have an out of position value on the left, but the
4025                      right is fully scanned, so I "slide" the pivot chunk
4026                      and any less-than values left one to make room for the
4027                      greater value over on the right. If the out of position
4028                      value is immediately adjacent to the pivot chunk (there
4029                      are no less-than values), I can do that with a swap,
4030                      otherwise, I have to rotate one of the less than values
4031                      into the former position of the out of position value
4032                      and the right end of the pivot chunk into the left end
4033                      (got all that?).
4034                   */
4035                   --pc_left;
4036                   if (pc_left == u_right) {
4037                      qsort_swap(u_right, pc_right);
4038                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4039                   } else {
4040                      qsort_rotate(u_right, pc_left, pc_right);
4041                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4042                   }
4043                   --pc_right;
4044                   --u_right;
4045                }
4046             } else if (still_work_on_right) {
4047                /* Mirror image of complex case above: I have an out of
4048                   position value on the right, but the left is fully
4049                   scanned, so I need to shuffle things around to make room
4050                   for the right value on the left.
4051                */
4052                ++pc_right;
4053                if (pc_right == u_left) {
4054                   qsort_swap(u_left, pc_left);
4055                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4056                } else {
4057                   qsort_rotate(pc_right, pc_left, u_left);
4058                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4059                }
4060                ++pc_left;
4061                ++u_left;
4062             } else {
4063                /* No more scanning required on either side of partition,
4064                   break out of loop and figure out next set of partitions
4065                */
4066                break;
4067             }
4068          }
4069
4070          /* The elements in the pivot chunk are now in the right place. They
4071             will never move or be compared again. All I have to do is decide
4072             what to do with the stuff to the left and right of the pivot
4073             chunk.
4074
4075             Notes on the QSORT_ORDER_GUESS ifdef code:
4076
4077             1. If I just built these partitions without swapping any (or
4078                very many) elements, there is a chance that the elements are
4079                already ordered properly (being properly ordered will
4080                certainly result in no swapping, but the converse can't be
4081                proved :-).
4082
4083             2. A (properly written) insertion sort will run faster on
4084                already ordered data than qsort will.
4085
4086             3. Perhaps there is some way to make a good guess about
4087                switching to an insertion sort earlier than partition size 6
4088                (for instance - we could save the partition size on the stack
4089                and increase the size each time we find we didn't swap, thus
4090                switching to insertion sort earlier for partitions with a
4091                history of not swapping).
4092
4093             4. Naturally, if I just switch right away, it will make
4094                artificial benchmarks with pure ascending (or descending)
4095                data look really good, but is that a good reason in general?
4096                Hard to say...
4097          */
4098
4099 #ifdef QSORT_ORDER_GUESS
4100          if (swapped < 3) {
4101 #if QSORT_ORDER_GUESS == 1
4102             qsort_break_even = (part_right - part_left) + 1;
4103 #endif
4104 #if QSORT_ORDER_GUESS == 2
4105             qsort_break_even *= 2;
4106 #endif
4107 #if QSORT_ORDER_GUESS == 3
4108             int prev_break = qsort_break_even;
4109             qsort_break_even *= qsort_break_even;
4110             if (qsort_break_even < prev_break) {
4111                qsort_break_even = (part_right - part_left) + 1;
4112             }
4113 #endif
4114          } else {
4115             qsort_break_even = QSORT_BREAK_EVEN;
4116          }
4117 #endif
4118
4119          if (part_left < pc_left) {
4120             /* There are elements on the left which need more processing.
4121                Check the right as well before deciding what to do.
4122             */
4123             if (pc_right < part_right) {
4124                /* We have two partitions to be sorted. Stack the biggest one
4125                   and process the smallest one on the next iteration. This
4126                   minimizes the stack height by insuring that any additional
4127                   stack entries must come from the smallest partition which
4128                   (because it is smallest) will have the fewest
4129                   opportunities to generate additional stack entries.
4130                */
4131                if ((part_right - pc_right) > (pc_left - part_left)) {
4132                   /* stack the right partition, process the left */
4133                   partition_stack[next_stack_entry].left = pc_right + 1;
4134                   partition_stack[next_stack_entry].right = part_right;
4135 #ifdef QSORT_ORDER_GUESS
4136                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4137 #endif
4138                   part_right = pc_left - 1;
4139                } else {
4140                   /* stack the left partition, process the right */
4141                   partition_stack[next_stack_entry].left = part_left;
4142                   partition_stack[next_stack_entry].right = pc_left - 1;
4143 #ifdef QSORT_ORDER_GUESS
4144                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4145 #endif
4146                   part_left = pc_right + 1;
4147                }
4148                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4149                ++next_stack_entry;
4150             } else {
4151                /* The elements on the left are the only remaining elements
4152                   that need sorting, arrange for them to be processed as the
4153                   next partition.
4154                */
4155                part_right = pc_left - 1;
4156             }
4157          } else if (pc_right < part_right) {
4158             /* There is only one chunk on the right to be sorted, make it
4159                the new partition and loop back around.
4160             */
4161             part_left = pc_right + 1;
4162          } else {
4163             /* This whole partition wound up in the pivot chunk, so
4164                we need to get a new partition off the stack.
4165             */
4166             if (next_stack_entry == 0) {
4167                /* the stack is empty - we are done */
4168                break;
4169             }
4170             --next_stack_entry;
4171             part_left = partition_stack[next_stack_entry].left;
4172             part_right = partition_stack[next_stack_entry].right;
4173 #ifdef QSORT_ORDER_GUESS
4174             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4175 #endif
4176          }
4177       } else {
4178          /* This partition is too small to fool with qsort complexity, just
4179             do an ordinary insertion sort to minimize overhead.
4180          */
4181          int i;
4182          /* Assume 1st element is in right place already, and start checking
4183             at 2nd element to see where it should be inserted.
4184          */
4185          for (i = part_left + 1; i <= part_right; ++i) {
4186             int j;
4187             /* Scan (backwards - just in case 'i' is already in right place)
4188                through the elements already sorted to see if the ith element
4189                belongs ahead of one of them.
4190             */
4191             for (j = i - 1; j >= part_left; --j) {
4192                if (qsort_cmp(i, j) >= 0) {
4193                   /* i belongs right after j
4194                   */
4195                   break;
4196                }
4197             }
4198             ++j;
4199             if (j != i) {
4200                /* Looks like we really need to move some things
4201                */
4202                int k;
4203                temp = array[i];
4204                for (k = i - 1; k >= j; --k)
4205                   array[k + 1] = array[k];
4206                array[j] = temp;
4207             }
4208          }
4209
4210          /* That partition is now sorted, grab the next one, or get out
4211             of the loop if there aren't any more.
4212          */
4213
4214          if (next_stack_entry == 0) {
4215             /* the stack is empty - we are done */
4216             break;
4217          }
4218          --next_stack_entry;
4219          part_left = partition_stack[next_stack_entry].left;
4220          part_right = partition_stack[next_stack_entry].right;
4221 #ifdef QSORT_ORDER_GUESS
4222          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4223 #endif
4224       }
4225    }
4226
4227    /* Believe it or not, the array is sorted at this point! */
4228 }
4229
4230
4231 #ifdef PERL_OBJECT
4232 #undef this
4233 #define this pPerl
4234 #include "XSUB.h"
4235 #endif
4236
4237
4238 static I32
4239 sortcv(pTHXo_ SV *a, SV *b)
4240 {
4241     dTHR;
4242     I32 oldsaveix = PL_savestack_ix;
4243     I32 oldscopeix = PL_scopestack_ix;
4244     I32 result;
4245     GvSV(PL_firstgv) = a;
4246     GvSV(PL_secondgv) = b;
4247     PL_stack_sp = PL_stack_base;
4248     PL_op = PL_sortcop;
4249     CALLRUNOPS(aTHX);
4250     if (PL_stack_sp != PL_stack_base + 1)
4251         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4252     if (!SvNIOKp(*PL_stack_sp))
4253         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4254     result = SvIV(*PL_stack_sp);
4255     while (PL_scopestack_ix > oldscopeix) {
4256         LEAVE;
4257     }
4258     leave_scope(oldsaveix);
4259     return result;
4260 }
4261
4262 static I32
4263 sortcv_stacked(pTHXo_ SV *a, SV *b)
4264 {
4265     dTHR;
4266     I32 oldsaveix = PL_savestack_ix;
4267     I32 oldscopeix = PL_scopestack_ix;
4268     I32 result;
4269     AV *av;
4270
4271 #ifdef USE_THREADS
4272     av = (AV*)PL_curpad[0];
4273 #else
4274     av = GvAV(PL_defgv);
4275 #endif
4276
4277     if (AvMAX(av) < 1) {
4278         SV** ary = AvALLOC(av);
4279         if (AvARRAY(av) != ary) {
4280             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4281             SvPVX(av) = (char*)ary;
4282         }
4283         if (AvMAX(av) < 1) {
4284             AvMAX(av) = 1;
4285             Renew(ary,2,SV*);
4286             SvPVX(av) = (char*)ary;
4287         }
4288     }
4289     AvFILLp(av) = 1;
4290
4291     AvARRAY(av)[0] = a;
4292     AvARRAY(av)[1] = b;
4293     PL_stack_sp = PL_stack_base;
4294     PL_op = PL_sortcop;
4295     CALLRUNOPS(aTHX);
4296     if (PL_stack_sp != PL_stack_base + 1)
4297         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4298     if (!SvNIOKp(*PL_stack_sp))
4299         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4300     result = SvIV(*PL_stack_sp);
4301     while (PL_scopestack_ix > oldscopeix) {
4302         LEAVE;
4303     }
4304     leave_scope(oldsaveix);
4305     return result;
4306 }
4307
4308 static I32
4309 sortcv_xsub(pTHXo_ SV *a, SV *b)
4310 {
4311     dSP;
4312     I32 oldsaveix = PL_savestack_ix;
4313     I32 oldscopeix = PL_scopestack_ix;
4314     I32 result;
4315     CV *cv=(CV*)PL_sortcop;
4316
4317     SP = PL_stack_base;
4318     PUSHMARK(SP);
4319     EXTEND(SP, 2);
4320     *++SP = a;
4321     *++SP = b;
4322     PUTBACK;
4323     (void)(*CvXSUB(cv))(aTHXo_ cv);
4324     if (PL_stack_sp != PL_stack_base + 1)
4325         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4326     if (!SvNIOKp(*PL_stack_sp))
4327         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4328     result = SvIV(*PL_stack_sp);
4329     while (PL_scopestack_ix > oldscopeix) {
4330         LEAVE;
4331     }
4332     leave_scope(oldsaveix);
4333     return result;
4334 }
4335
4336
4337 static I32
4338 sv_ncmp(pTHXo_ SV *a, SV *b)
4339 {
4340     NV nv1 = SvNV(a);
4341     NV nv2 = SvNV(b);
4342     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4343 }
4344
4345 static I32
4346 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4347 {
4348     IV iv1 = SvIV(a);
4349     IV iv2 = SvIV(b);
4350     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4351 }
4352 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4353           *svp = Nullsv;                                \
4354           if (PL_amagic_generation) { \
4355             if (SvAMAGIC(left)||SvAMAGIC(right))\
4356                 *svp = amagic_call(left, \
4357                                    right, \
4358                                    CAT2(meth,_amg), \
4359                                    0); \
4360           } \
4361         } STMT_END
4362
4363 static I32
4364 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4365 {
4366     SV *tmpsv;
4367     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4368     if (tmpsv) {
4369         NV d;
4370
4371         if (SvIOK(tmpsv)) {
4372             I32 i = SvIVX(tmpsv);
4373             if (i > 0)
4374                return 1;
4375             return i? -1 : 0;
4376         }
4377         d = SvNV(tmpsv);
4378         if (d > 0)
4379            return 1;
4380         return d? -1 : 0;
4381      }
4382      return sv_ncmp(aTHXo_ a, b);
4383 }
4384
4385 static I32
4386 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4387 {
4388     SV *tmpsv;
4389     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4390     if (tmpsv) {
4391         NV d;
4392
4393         if (SvIOK(tmpsv)) {
4394             I32 i = SvIVX(tmpsv);
4395             if (i > 0)
4396                return 1;
4397             return i? -1 : 0;
4398         }
4399         d = SvNV(tmpsv);
4400         if (d > 0)
4401            return 1;
4402         return d? -1 : 0;
4403     }
4404     return sv_i_ncmp(aTHXo_ a, b);
4405 }
4406
4407 static I32
4408 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4409 {
4410     SV *tmpsv;
4411     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4412     if (tmpsv) {
4413         NV d;
4414
4415         if (SvIOK(tmpsv)) {
4416             I32 i = SvIVX(tmpsv);
4417             if (i > 0)
4418                return 1;
4419             return i? -1 : 0;
4420         }
4421         d = SvNV(tmpsv);
4422         if (d > 0)
4423            return 1;
4424         return d? -1 : 0;
4425     }
4426     return sv_cmp(str1, str2);
4427 }
4428
4429 static I32
4430 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4431 {
4432     SV *tmpsv;
4433     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4434     if (tmpsv) {
4435         NV d;
4436
4437         if (SvIOK(tmpsv)) {
4438             I32 i = SvIVX(tmpsv);
4439             if (i > 0)
4440                return 1;
4441             return i? -1 : 0;
4442         }
4443         d = SvNV(tmpsv);
4444         if (d > 0)
4445            return 1;
4446         return d? -1 : 0;
4447     }
4448     return sv_cmp_locale(str1, str2);
4449 }
4450
4451 static I32
4452 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4453 {
4454     SV *datasv = FILTER_DATA(idx);
4455     int filter_has_file = IoLINES(datasv);
4456     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4457     SV *filter_state = (SV *)IoTOP_GV(datasv);
4458     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4459     int len = 0;
4460
4461     /* I was having segfault trouble under Linux 2.2.5 after a
4462        parse error occured.  (Had to hack around it with a test
4463        for PL_error_count == 0.)  Solaris doesn't segfault --
4464        not sure where the trouble is yet.  XXX */
4465
4466     if (filter_has_file) {
4467         len = FILTER_READ(idx+1, buf_sv, maxlen);
4468     }
4469
4470     if (filter_sub && len >= 0) {
4471         djSP;
4472         int count;
4473
4474         ENTER;
4475         SAVE_DEFSV;
4476         SAVETMPS;
4477         EXTEND(SP, 2);
4478
4479         DEFSV = buf_sv;
4480         PUSHMARK(SP);
4481         PUSHs(sv_2mortal(newSViv(maxlen)));
4482         if (filter_state) {
4483             PUSHs(filter_state);
4484         }
4485         PUTBACK;
4486         count = call_sv(filter_sub, G_SCALAR);
4487         SPAGAIN;
4488
4489         if (count > 0) {
4490             SV *out = POPs;
4491             if (SvOK(out)) {
4492                 len = SvIV(out);
4493             }
4494         }
4495
4496         PUTBACK;
4497         FREETMPS;
4498         LEAVE;
4499     }
4500
4501     if (len <= 0) {
4502         IoLINES(datasv) = 0;
4503         if (filter_child_proc) {
4504             SvREFCNT_dec(filter_child_proc);
4505             IoFMT_GV(datasv) = Nullgv;
4506         }
4507         if (filter_state) {
4508             SvREFCNT_dec(filter_state);
4509             IoTOP_GV(datasv) = Nullgv;
4510         }
4511         if (filter_sub) {
4512             SvREFCNT_dec(filter_sub);
4513             IoBOTTOM_GV(datasv) = Nullgv;
4514         }
4515         filter_del(run_user_filter);
4516     }
4517
4518     return len;
4519 }
4520
4521 #ifdef PERL_OBJECT
4522
4523 static I32
4524 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4525 {
4526     return sv_cmp_locale(str1, str2);
4527 }
4528
4529 static I32
4530 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4531 {
4532     return sv_cmp(str1, str2);
4533 }
4534
4535 #endif /* PERL_OBJECT */