pp_ctl.c

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