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     TOPBLOCK(cx);
1963     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1964     LEAVE_SCOPE(oldsave);
1965     return cx->blk_loop.next_op;
1966 }
1967
1968 PP(pp_redo)
1969 {
1970     I32 cxix;
1971     register PERL_CONTEXT *cx;
1972     I32 oldsave;
1973
1974     if (PL_op->op_flags & OPf_SPECIAL) {
1975         cxix = dopoptoloop(cxstack_ix);
1976         if (cxix < 0)
1977             DIE(aTHX_ "Can't \"redo\" outside a loop block");
1978     }
1979     else {
1980         cxix = dopoptolabel(cPVOP->op_pv);
1981         if (cxix < 0)
1982             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1983     }
1984     if (cxix < cxstack_ix)
1985         dounwind(cxix);
1986
1987     TOPBLOCK(cx);
1988     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1989     LEAVE_SCOPE(oldsave);
1990     return cx->blk_loop.redo_op;
1991 }
1992
1993 STATIC OP *
1994 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1995 {
1996     OP *kid;
1997     OP **ops = opstack;
1998     static char too_deep[] = "Target of goto is too deeply nested";
1999
2000     if (ops >= oplimit)
2001         Perl_croak(aTHX_ too_deep);
2002     if (o->op_type == OP_LEAVE ||
2003         o->op_type == OP_SCOPE ||
2004         o->op_type == OP_LEAVELOOP ||
2005         o->op_type == OP_LEAVETRY)
2006     {
2007         *ops++ = cUNOPo->op_first;
2008         if (ops >= oplimit)
2009             Perl_croak(aTHX_ too_deep);
2010     }
2011     *ops = 0;
2012     if (o->op_flags & OPf_KIDS) {
2013         dTHR;
2014         /* First try all the kids at this level, since that's likeliest. */
2015         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2016             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2017                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2018                 return kid;
2019         }
2020         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2021             if (kid == PL_lastgotoprobe)
2022                 continue;
2023             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2024                 (ops == opstack ||
2025                  (ops[-1]->op_type != OP_NEXTSTATE &&
2026                   ops[-1]->op_type != OP_DBSTATE)))
2027                 *ops++ = kid;
2028             if (o = dofindlabel(kid, label, ops, oplimit))
2029                 return o;
2030         }
2031     }
2032     *ops = 0;
2033     return 0;
2034 }
2035
2036 PP(pp_dump)
2037 {
2038     return pp_goto();
2039     /*NOTREACHED*/
2040 }
2041
2042 PP(pp_goto)
2043 {
2044     djSP;
2045     OP *retop = 0;
2046     I32 ix;
2047     register PERL_CONTEXT *cx;
2048 #define GOTO_DEPTH 64
2049     OP *enterops[GOTO_DEPTH];
2050     char *label;
2051     int do_dump = (PL_op->op_type == OP_DUMP);
2052     static char must_have_label[] = "goto must have label";
2053
2054     label = 0;
2055     if (PL_op->op_flags & OPf_STACKED) {
2056         SV *sv = POPs;
2057         STRLEN n_a;
2058
2059         /* This egregious kludge implements goto &subroutine */
2060         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2061             I32 cxix;
2062             register PERL_CONTEXT *cx;
2063             CV* cv = (CV*)SvRV(sv);
2064             SV** mark;
2065             I32 items = 0;
2066             I32 oldsave;
2067
2068         retry:
2069             if (!CvROOT(cv) && !CvXSUB(cv)) {
2070                 GV *gv = CvGV(cv);
2071                 GV *autogv;
2072                 if (gv) {
2073                     SV *tmpstr;
2074                     /* autoloaded stub? */
2075                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2076                         goto retry;
2077                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2078                                           GvNAMELEN(gv), FALSE);
2079                     if (autogv && (cv = GvCV(autogv)))
2080                         goto retry;
2081                     tmpstr = sv_newmortal();
2082                     gv_efullname3(tmpstr, gv, Nullch);
2083                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2084                 }
2085                 DIE(aTHX_ "Goto undefined subroutine");
2086             }
2087
2088             /* First do some returnish stuff. */
2089             cxix = dopoptosub(cxstack_ix);
2090             if (cxix < 0)
2091                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2092             if (cxix < cxstack_ix)
2093                 dounwind(cxix);
2094             TOPBLOCK(cx);
2095             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2096                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2097             mark = PL_stack_sp;
2098             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2099                 /* put @_ back onto stack */
2100                 AV* av = cx->blk_sub.argarray;
2101
2102                 items = AvFILLp(av) + 1;
2103                 PL_stack_sp++;
2104                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2105                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2106                 PL_stack_sp += items;
2107 #ifndef USE_THREADS
2108                 SvREFCNT_dec(GvAV(PL_defgv));
2109                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2110 #endif /* USE_THREADS */
2111                 /* abandon @_ if it got reified */
2112                 if (AvREAL(av)) {
2113                     (void)sv_2mortal((SV*)av);  /* delay until return */
2114                     av = newAV();
2115                     av_extend(av, items-1);
2116                     AvFLAGS(av) = AVf_REIFY;
2117                     PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2118                 }
2119             }
2120             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2121                 AV* av;
2122                 int i;
2123 #ifdef USE_THREADS
2124                 av = (AV*)PL_curpad[0];
2125 #else
2126                 av = GvAV(PL_defgv);
2127 #endif
2128                 items = AvFILLp(av) + 1;
2129                 PL_stack_sp++;
2130                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2131                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2132                 PL_stack_sp += items;
2133             }
2134             if (CxTYPE(cx) == CXt_SUB &&
2135                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2136                 SvREFCNT_dec(cx->blk_sub.cv);
2137             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2138             LEAVE_SCOPE(oldsave);
2139
2140             /* Now do some callish stuff. */
2141             SAVETMPS;
2142             if (CvXSUB(cv)) {
2143 #ifdef PERL_XSUB_OLDSTYLE
2144                 if (CvOLDSTYLE(cv)) {
2145                     I32 (*fp3)(int,int,int);
2146                     while (SP > mark) {
2147                         SP[1] = SP[0];
2148                         SP--;
2149                     }
2150                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2151                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2152                                    mark - PL_stack_base + 1,
2153                                    items);
2154                     SP = PL_stack_base + items;
2155                 }
2156                 else
2157 #endif /* PERL_XSUB_OLDSTYLE */
2158                 {
2159                     SV **newsp;
2160                     I32 gimme;
2161
2162                     PL_stack_sp--;              /* There is no cv arg. */
2163                     /* Push a mark for the start of arglist */
2164                     PUSHMARK(mark);
2165                     (void)(*CvXSUB(cv))(aTHXo_ cv);
2166                     /* Pop the current context like a decent sub should */
2167                     POPBLOCK(cx, PL_curpm);
2168                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2169                 }
2170                 LEAVE;
2171                 return pop_return();
2172             }
2173             else {
2174                 AV* padlist = CvPADLIST(cv);
2175                 SV** svp = AvARRAY(padlist);
2176                 if (CxTYPE(cx) == CXt_EVAL) {
2177                     PL_in_eval = cx->blk_eval.old_in_eval;
2178                     PL_eval_root = cx->blk_eval.old_eval_root;
2179                     cx->cx_type = CXt_SUB;
2180                     cx->blk_sub.hasargs = 0;
2181                 }
2182                 cx->blk_sub.cv = cv;
2183                 cx->blk_sub.olddepth = CvDEPTH(cv);
2184                 CvDEPTH(cv)++;
2185                 if (CvDEPTH(cv) < 2)
2186                     (void)SvREFCNT_inc(cv);
2187                 else {  /* save temporaries on recursion? */
2188                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2189                         sub_crush_depth(cv);
2190                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2191                         AV *newpad = newAV();
2192                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2193                         I32 ix = AvFILLp((AV*)svp[1]);
2194                         I32 names_fill = AvFILLp((AV*)svp[0]);
2195                         svp = AvARRAY(svp[0]);
2196                         for ( ;ix > 0; ix--) {
2197                             if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2198                                 char *name = SvPVX(svp[ix]);
2199                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2200                                     || *name == '&')
2201                                 {
2202                                     /* outer lexical or anon code */
2203                                     av_store(newpad, ix,
2204                                         SvREFCNT_inc(oldpad[ix]) );
2205                                 }
2206                                 else {          /* our own lexical */
2207                                     if (*name == '@')
2208                                         av_store(newpad, ix, sv = (SV*)newAV());
2209                                     else if (*name == '%')
2210                                         av_store(newpad, ix, sv = (SV*)newHV());
2211                                     else
2212                                         av_store(newpad, ix, sv = NEWSV(0,0));
2213                                     SvPADMY_on(sv);
2214                                 }
2215                             }
2216                             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2217                                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2218                             }
2219                             else {
2220                                 av_store(newpad, ix, sv = NEWSV(0,0));
2221                                 SvPADTMP_on(sv);
2222                             }
2223                         }
2224                         if (cx->blk_sub.hasargs) {
2225                             AV* av = newAV();
2226                             av_extend(av, 0);
2227                             av_store(newpad, 0, (SV*)av);
2228                             AvFLAGS(av) = AVf_REIFY;
2229                         }
2230                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2231                         AvFILLp(padlist) = CvDEPTH(cv);
2232                         svp = AvARRAY(padlist);
2233                     }
2234                 }
2235 #ifdef USE_THREADS
2236                 if (!cx->blk_sub.hasargs) {
2237                     AV* av = (AV*)PL_curpad[0];
2238
2239                     items = AvFILLp(av) + 1;
2240                     if (items) {
2241                         /* Mark is at the end of the stack. */
2242                         EXTEND(SP, items);
2243                         Copy(AvARRAY(av), SP + 1, items, SV*);
2244                         SP += items;
2245                         PUTBACK ;
2246                     }
2247                 }
2248 #endif /* USE_THREADS */
2249                 SAVEVPTR(PL_curpad);
2250                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2251 #ifndef USE_THREADS
2252                 if (cx->blk_sub.hasargs)
2253 #endif /* USE_THREADS */
2254                 {
2255                     AV* av = (AV*)PL_curpad[0];
2256                     SV** ary;
2257
2258 #ifndef USE_THREADS
2259                     cx->blk_sub.savearray = GvAV(PL_defgv);
2260                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2261 #endif /* USE_THREADS */
2262                     cx->blk_sub.argarray = av;
2263                     ++mark;
2264
2265                     if (items >= AvMAX(av) + 1) {
2266                         ary = AvALLOC(av);
2267                         if (AvARRAY(av) != ary) {
2268                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2269                             SvPVX(av) = (char*)ary;
2270                         }
2271                         if (items >= AvMAX(av) + 1) {
2272                             AvMAX(av) = items - 1;
2273                             Renew(ary,items+1,SV*);
2274                             AvALLOC(av) = ary;
2275                             SvPVX(av) = (char*)ary;
2276                         }
2277                     }
2278                     Copy(mark,AvARRAY(av),items,SV*);
2279                     AvFILLp(av) = items - 1;
2280                     assert(!AvREAL(av));
2281                     while (items--) {
2282                         if (*mark)
2283                             SvTEMP_off(*mark);
2284                         mark++;
2285                     }
2286                 }
2287                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2288                     /*
2289                      * We do not care about using sv to call CV;
2290                      * it's for informational purposes only.
2291                      */
2292                     SV *sv = GvSV(PL_DBsub);
2293                     CV *gotocv;
2294
2295                     if (PERLDB_SUB_NN) {
2296                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2297                     } else {
2298                         save_item(sv);
2299                         gv_efullname3(sv, CvGV(cv), Nullch);
2300                     }
2301                     if (  PERLDB_GOTO
2302                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2303                         PUSHMARK( PL_stack_sp );
2304                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2305                         PL_stack_sp--;
2306                     }
2307                 }
2308                 RETURNOP(CvSTART(cv));
2309             }
2310         }
2311         else {
2312             label = SvPV(sv,n_a);
2313             if (!(do_dump || *label))
2314                 DIE(aTHX_ must_have_label);
2315         }
2316     }
2317     else if (PL_op->op_flags & OPf_SPECIAL) {
2318         if (! do_dump)
2319             DIE(aTHX_ must_have_label);
2320     }
2321     else
2322         label = cPVOP->op_pv;
2323
2324     if (label && *label) {
2325         OP *gotoprobe = 0;
2326
2327         /* find label */
2328
2329         PL_lastgotoprobe = 0;
2330         *enterops = 0;
2331         for (ix = cxstack_ix; ix >= 0; ix--) {
2332             cx = &cxstack[ix];
2333             switch (CxTYPE(cx)) {
2334             case CXt_EVAL:
2335                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2336                 break;
2337             case CXt_LOOP:
2338                 gotoprobe = cx->blk_oldcop->op_sibling;
2339                 break;
2340             case CXt_SUBST:
2341                 continue;
2342             case CXt_BLOCK:
2343                 if (ix)
2344                     gotoprobe = cx->blk_oldcop->op_sibling;
2345                 else
2346                     gotoprobe = PL_main_root;
2347                 break;
2348             case CXt_SUB:
2349                 if (CvDEPTH(cx->blk_sub.cv)) {
2350                     gotoprobe = CvROOT(cx->blk_sub.cv);
2351                     break;
2352                 }
2353                 /* FALL THROUGH */
2354             case CXt_FORMAT:
2355             case CXt_NULL:
2356                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2357             default:
2358                 if (ix)
2359                     DIE(aTHX_ "panic: goto");
2360                 gotoprobe = PL_main_root;
2361                 break;
2362             }
2363             retop = dofindlabel(gotoprobe, label,
2364                                 enterops, enterops + GOTO_DEPTH);
2365             if (retop)
2366                 break;
2367             PL_lastgotoprobe = gotoprobe;
2368         }
2369         if (!retop)
2370             DIE(aTHX_ "Can't find label %s", label);
2371
2372         /* pop unwanted frames */
2373
2374         if (ix < cxstack_ix) {
2375             I32 oldsave;
2376
2377             if (ix < 0)
2378                 ix = 0;
2379             dounwind(ix);
2380             TOPBLOCK(cx);
2381             oldsave = PL_scopestack[PL_scopestack_ix];
2382             LEAVE_SCOPE(oldsave);
2383         }
2384
2385         /* push wanted frames */
2386
2387         if (*enterops && enterops[1]) {
2388             OP *oldop = PL_op;
2389             for (ix = 1; enterops[ix]; ix++) {
2390                 PL_op = enterops[ix];
2391                 /* Eventually we may want to stack the needed arguments
2392                  * for each op.  For now, we punt on the hard ones. */
2393                 if (PL_op->op_type == OP_ENTERITER)
2394                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2395                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2396             }
2397             PL_op = oldop;
2398         }
2399     }
2400
2401     if (do_dump) {
2402 #ifdef VMS
2403         if (!retop) retop = PL_main_start;
2404 #endif
2405         PL_restartop = retop;
2406         PL_do_undump = TRUE;
2407
2408         my_unexec();
2409
2410         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2411         PL_do_undump = FALSE;
2412     }
2413
2414     RETURNOP(retop);
2415 }
2416
2417 PP(pp_exit)
2418 {
2419     djSP;
2420     I32 anum;
2421
2422     if (MAXARG < 1)
2423         anum = 0;
2424     else {
2425         anum = SvIVx(POPs);
2426 #ifdef VMSISH_EXIT
2427         if (anum == 1 && VMSISH_EXIT)
2428             anum = 0;
2429 #endif
2430     }
2431     PL_exit_flags |= PERL_EXIT_EXPECTED;
2432     my_exit(anum);
2433     PUSHs(&PL_sv_undef);
2434     RETURN;
2435 }
2436
2437 #ifdef NOTYET
2438 PP(pp_nswitch)
2439 {
2440     djSP;
2441     NV value = SvNVx(GvSV(cCOP->cop_gv));
2442     register I32 match = I_32(value);
2443
2444     if (value < 0.0) {
2445         if (((NV)match) > value)
2446             --match;            /* was fractional--truncate other way */
2447     }
2448     match -= cCOP->uop.scop.scop_offset;
2449     if (match < 0)
2450         match = 0;
2451     else if (match > cCOP->uop.scop.scop_max)
2452         match = cCOP->uop.scop.scop_max;
2453     PL_op = cCOP->uop.scop.scop_next[match];
2454     RETURNOP(PL_op);
2455 }
2456
2457 PP(pp_cswitch)
2458 {
2459     djSP;
2460     register I32 match;
2461
2462     if (PL_multiline)
2463         PL_op = PL_op->op_next;                 /* can't assume anything */
2464     else {
2465         STRLEN n_a;
2466         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2467         match -= cCOP->uop.scop.scop_offset;
2468         if (match < 0)
2469             match = 0;
2470         else if (match > cCOP->uop.scop.scop_max)
2471             match = cCOP->uop.scop.scop_max;
2472         PL_op = cCOP->uop.scop.scop_next[match];
2473     }
2474     RETURNOP(PL_op);
2475 }
2476 #endif
2477
2478 /* Eval. */
2479
2480 STATIC void
2481 S_save_lines(pTHX_ AV *array, SV *sv)
2482 {
2483     register char *s = SvPVX(sv);
2484     register char *send = SvPVX(sv) + SvCUR(sv);
2485     register char *t;
2486     register I32 line = 1;
2487
2488     while (s && s < send) {
2489         SV *tmpstr = NEWSV(85,0);
2490
2491         sv_upgrade(tmpstr, SVt_PVMG);
2492         t = strchr(s, '\n');
2493         if (t)
2494             t++;
2495         else
2496             t = send;
2497
2498         sv_setpvn(tmpstr, s, t - s);
2499         av_store(array, line++, tmpstr);
2500         s = t;
2501     }
2502 }
2503
2504 STATIC void *
2505 S_docatch_body(pTHX_ va_list args)
2506 {
2507     CALLRUNOPS(aTHX);
2508     return NULL;
2509 }
2510
2511 STATIC OP *
2512 S_docatch(pTHX_ OP *o)
2513 {
2514     dTHR;
2515     int ret;
2516     OP *oldop = PL_op;
2517     volatile PERL_SI *cursi = PL_curstackinfo;
2518     dJMPENV;
2519
2520 #ifdef DEBUGGING
2521     assert(CATCH_GET == TRUE);
2522 #endif
2523     PL_op = o;
2524  redo_body:
2525     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2526     switch (ret) {
2527     case 0:
2528         break;
2529     case 3:
2530         if (PL_restartop && cursi == PL_curstackinfo) {
2531             PL_op = PL_restartop;
2532             PL_restartop = 0;
2533             goto redo_body;
2534         }
2535         /* FALL THROUGH */
2536     default:
2537         PL_op = oldop;
2538         JMPENV_JUMP(ret);
2539         /* NOTREACHED */
2540     }
2541     PL_op = oldop;
2542     return Nullop;
2543 }
2544
2545 OP *
2546 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2547 /* sv Text to convert to OP tree. */
2548 /* startop op_free() this to undo. */
2549 /* code Short string id of the caller. */
2550 {
2551     dSP;                                /* Make POPBLOCK work. */
2552     PERL_CONTEXT *cx;
2553     SV **newsp;
2554     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2555     I32 optype;
2556     OP dummy;
2557     OP *oop = PL_op, *rop;
2558     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2559     char *safestr;
2560
2561     ENTER;
2562     lex_start(sv);
2563     SAVETMPS;
2564     /* switch to eval mode */
2565
2566     if (PL_curcop == &PL_compiling) {
2567         SAVECOPSTASH(&PL_compiling);
2568         CopSTASH_set(&PL_compiling, PL_curstash);
2569     }
2570     SAVECOPFILE(&PL_compiling);
2571     SAVECOPLINE(&PL_compiling);
2572     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2573     CopFILE_set(&PL_compiling, tmpbuf+2);
2574     CopLINE_set(&PL_compiling, 1);
2575     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2576        deleting the eval's FILEGV from the stash before gv_check() runs
2577        (i.e. before run-time proper). To work around the coredump that
2578        ensues, we always turn GvMULTI_on for any globals that were
2579        introduced within evals. See force_ident(). GSAR 96-10-12 */
2580     safestr = savepv(tmpbuf);
2581     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2582     SAVEHINTS();
2583 #ifdef OP_IN_REGISTER
2584     PL_opsave = op;
2585 #else
2586     SAVEVPTR(PL_op);
2587 #endif
2588     PL_hints = 0;
2589
2590     PL_op = &dummy;
2591     PL_op->op_type = OP_ENTEREVAL;
2592     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2593     PUSHBLOCK(cx, CXt_EVAL, SP);
2594     PUSHEVAL(cx, 0, Nullgv);
2595     rop = doeval(G_SCALAR, startop);
2596     POPBLOCK(cx,PL_curpm);
2597     POPEVAL(cx);
2598
2599     (*startop)->op_type = OP_NULL;
2600     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2601     lex_end();
2602     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2603     LEAVE;
2604     if (PL_curcop == &PL_compiling)
2605         PL_compiling.op_private = PL_hints;
2606 #ifdef OP_IN_REGISTER
2607     op = PL_opsave;
2608 #endif
2609     return rop;
2610 }
2611
2612 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2613 STATIC OP *
2614 S_doeval(pTHX_ int gimme, OP** startop)
2615 {
2616     dSP;
2617     OP *saveop = PL_op;
2618     CV *caller;
2619     AV* comppadlist;
2620     I32 i;
2621
2622     PL_in_eval = EVAL_INEVAL;
2623
2624     PUSHMARK(SP);
2625
2626     /* set up a scratch pad */
2627
2628     SAVEI32(PL_padix);
2629     SAVEVPTR(PL_curpad);
2630     SAVESPTR(PL_comppad);
2631     SAVESPTR(PL_comppad_name);
2632     SAVEI32(PL_comppad_name_fill);
2633     SAVEI32(PL_min_intro_pending);
2634     SAVEI32(PL_max_intro_pending);
2635
2636     caller = PL_compcv;
2637     for (i = cxstack_ix - 1; i >= 0; i--) {
2638         PERL_CONTEXT *cx = &cxstack[i];
2639         if (CxTYPE(cx) == CXt_EVAL)
2640             break;
2641         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2642             caller = cx->blk_sub.cv;
2643             break;
2644         }
2645     }
2646
2647     SAVESPTR(PL_compcv);
2648     PL_compcv = (CV*)NEWSV(1104,0);
2649     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2650     CvEVAL_on(PL_compcv);
2651 #ifdef USE_THREADS
2652     CvOWNER(PL_compcv) = 0;
2653     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2654     MUTEX_INIT(CvMUTEXP(PL_compcv));
2655 #endif /* USE_THREADS */
2656
2657     PL_comppad = newAV();
2658     av_push(PL_comppad, Nullsv);
2659     PL_curpad = AvARRAY(PL_comppad);
2660     PL_comppad_name = newAV();
2661     PL_comppad_name_fill = 0;
2662     PL_min_intro_pending = 0;
2663     PL_padix = 0;
2664 #ifdef USE_THREADS
2665     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2666     PL_curpad[0] = (SV*)newAV();
2667     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2668 #endif /* USE_THREADS */
2669
2670     comppadlist = newAV();
2671     AvREAL_off(comppadlist);
2672     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2673     av_store(comppadlist, 1, (SV*)PL_comppad);
2674     CvPADLIST(PL_compcv) = comppadlist;
2675
2676     if (!saveop || saveop->op_type != OP_REQUIRE)
2677         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2678
2679     SAVEFREESV(PL_compcv);
2680
2681     /* make sure we compile in the right package */
2682
2683     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2684         SAVESPTR(PL_curstash);
2685         PL_curstash = CopSTASH(PL_curcop);
2686     }
2687     SAVESPTR(PL_beginav);
2688     PL_beginav = newAV();
2689     SAVEFREESV(PL_beginav);
2690
2691     /* try to compile it */
2692
2693     PL_eval_root = Nullop;
2694     PL_error_count = 0;
2695     PL_curcop = &PL_compiling;
2696     PL_curcop->cop_arybase = 0;
2697     SvREFCNT_dec(PL_rs);
2698     PL_rs = newSVpvn("\n", 1);
2699     if (saveop && saveop->op_flags & OPf_SPECIAL)
2700         PL_in_eval |= EVAL_KEEPERR;
2701     else
2702         sv_setpv(ERRSV,"");
2703     if (yyparse() || PL_error_count || !PL_eval_root) {
2704         SV **newsp;
2705         I32 gimme;
2706         PERL_CONTEXT *cx;
2707         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2708         STRLEN n_a;
2709
2710         PL_op = saveop;
2711         if (PL_eval_root) {
2712             op_free(PL_eval_root);
2713             PL_eval_root = Nullop;
2714         }
2715         SP = PL_stack_base + POPMARK;           /* pop original mark */
2716         if (!startop) {
2717             POPBLOCK(cx,PL_curpm);
2718             POPEVAL(cx);
2719             pop_return();
2720         }
2721         lex_end();
2722         LEAVE;
2723         if (optype == OP_REQUIRE) {
2724             char* msg = SvPVx(ERRSV, n_a);
2725             DIE(aTHX_ "%sCompilation failed in require",
2726                 *msg ? msg : "Unknown error\n");
2727         }
2728         else if (startop) {
2729             char* msg = SvPVx(ERRSV, n_a);
2730
2731             POPBLOCK(cx,PL_curpm);
2732             POPEVAL(cx);
2733             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2734                        (*msg ? msg : "Unknown error\n"));
2735         }
2736         SvREFCNT_dec(PL_rs);
2737         PL_rs = SvREFCNT_inc(PL_nrs);
2738 #ifdef USE_THREADS
2739         MUTEX_LOCK(&PL_eval_mutex);
2740         PL_eval_owner = 0;
2741         COND_SIGNAL(&PL_eval_cond);
2742         MUTEX_UNLOCK(&PL_eval_mutex);
2743 #endif /* USE_THREADS */
2744         RETPUSHUNDEF;
2745     }
2746     SvREFCNT_dec(PL_rs);
2747     PL_rs = SvREFCNT_inc(PL_nrs);
2748     CopLINE_set(&PL_compiling, 0);
2749     if (startop) {
2750         *startop = PL_eval_root;
2751         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2752         CvOUTSIDE(PL_compcv) = Nullcv;
2753     } else
2754         SAVEFREEOP(PL_eval_root);
2755     if (gimme & G_VOID)
2756         scalarvoid(PL_eval_root);
2757     else if (gimme & G_ARRAY)
2758         list(PL_eval_root);
2759     else
2760         scalar(PL_eval_root);
2761
2762     DEBUG_x(dump_eval());
2763
2764     /* Register with debugger: */
2765     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2766         CV *cv = get_cv("DB::postponed", FALSE);
2767         if (cv) {
2768             dSP;
2769             PUSHMARK(SP);
2770             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2771             PUTBACK;
2772             call_sv((SV*)cv, G_DISCARD);
2773         }
2774     }
2775
2776     /* compiled okay, so do it */
2777
2778     CvDEPTH(PL_compcv) = 1;
2779     SP = PL_stack_base + POPMARK;               /* pop original mark */
2780     PL_op = saveop;                     /* The caller may need it. */
2781 #ifdef USE_THREADS
2782     MUTEX_LOCK(&PL_eval_mutex);
2783     PL_eval_owner = 0;
2784     COND_SIGNAL(&PL_eval_cond);
2785     MUTEX_UNLOCK(&PL_eval_mutex);
2786 #endif /* USE_THREADS */
2787
2788     RETURNOP(PL_eval_start);
2789 }
2790
2791 STATIC PerlIO *
2792 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2793 {
2794     STRLEN namelen = strlen(name);
2795     PerlIO *fp;
2796
2797     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2798         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2799         char *pmc = SvPV_nolen(pmcsv);
2800         Stat_t pmstat;
2801         Stat_t pmcstat;
2802         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2803             fp = PerlIO_open(name, mode);
2804         }
2805         else {
2806             if (PerlLIO_stat(name, &pmstat) < 0 ||
2807                 pmstat.st_mtime < pmcstat.st_mtime)
2808             {
2809                 fp = PerlIO_open(pmc, mode);
2810             }
2811             else {
2812                 fp = PerlIO_open(name, mode);
2813             }
2814         }
2815         SvREFCNT_dec(pmcsv);
2816     }
2817     else {
2818         fp = PerlIO_open(name, mode);
2819     }
2820     return fp;
2821 }
2822
2823 PP(pp_require)
2824 {
2825     djSP;
2826     register PERL_CONTEXT *cx;
2827     SV *sv;
2828     char *name;
2829     STRLEN len;
2830     char *tryname;
2831     SV *namesv = Nullsv;
2832     SV** svp;
2833     I32 gimme = G_SCALAR;
2834     PerlIO *tryrsfp = 0;
2835     STRLEN n_a;
2836     int filter_has_file = 0;
2837     GV *filter_child_proc = 0;
2838     SV *filter_state = 0;
2839     SV *filter_sub = 0;
2840
2841     sv = POPs;
2842     if (SvNIOKp(sv)) {
2843         UV rev, ver, sver;
2844         if (SvPOKp(sv) && SvUTF8(sv)) {         /* require v5.6.1 */
2845             I32 len;
2846             U8 *s = (U8*)SvPVX(sv);
2847             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2848             if (s < end) {
2849                 rev = utf8_to_uv(s, &len);
2850                 s += len;
2851                 if (s < end) {
2852                     ver = utf8_to_uv(s, &len);
2853                     s += len;
2854                     if (s < end)
2855                         sver = utf8_to_uv(s, &len);
2856                     else
2857                         sver = 0;
2858                 }
2859                 else
2860                     ver = 0;
2861             }
2862             else
2863                 rev = 0;
2864             if (PERL_REVISION < rev
2865                 || (PERL_REVISION == rev
2866                     && (PERL_VERSION < ver
2867                         || (PERL_VERSION == ver
2868                             && PERL_SUBVERSION < sver))))
2869             {
2870                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2871                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2872                     PERL_VERSION, PERL_SUBVERSION);
2873             }
2874         }
2875         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2876             NV n = SvNV(sv);
2877             rev = (UV)n;
2878             ver = (UV)((n-rev)*1000);
2879             sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
2880
2881             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2882                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2883                 + 0.00000099 < SvNV(sv))
2884             {
2885                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2886                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2887                     PERL_VERSION, PERL_SUBVERSION);
2888             }
2889         }
2890         RETPUSHYES;
2891     }
2892     name = SvPV(sv, len);
2893     if (!(name && len > 0 && *name))
2894         DIE(aTHX_ "Null filename used");
2895     TAINT_PROPER("require");
2896     if (PL_op->op_type == OP_REQUIRE &&
2897       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2898       *svp != &PL_sv_undef)
2899         RETPUSHYES;
2900
2901     /* prepare to compile file */
2902
2903     if (PERL_FILE_IS_ABSOLUTE(name)
2904         || (*name == '.' && (name[1] == '/' ||
2905                              (name[1] == '.' && name[2] == '/'))))
2906     {
2907         tryname = name;
2908         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2909     }
2910     else {
2911         AV *ar = GvAVn(PL_incgv);
2912         I32 i;
2913 #ifdef VMS
2914         char *unixname;
2915         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2916 #endif
2917         {
2918             namesv = NEWSV(806, 0);
2919             for (i = 0; i <= AvFILL(ar); i++) {
2920                 SV *dirsv = *av_fetch(ar, i, TRUE);
2921
2922                 if (SvROK(dirsv)) {
2923                     int count;
2924                     SV *loader = dirsv;
2925
2926                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2927                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2928                     }
2929
2930                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2931                                    PTR2UV(SvANY(loader)), name);
2932                     tryname = SvPVX(namesv);
2933                     tryrsfp = 0;
2934
2935                     ENTER;
2936                     SAVETMPS;
2937                     EXTEND(SP, 2);
2938
2939                     PUSHMARK(SP);
2940                     PUSHs(dirsv);
2941                     PUSHs(sv);
2942                     PUTBACK;
2943                     count = call_sv(loader, G_ARRAY);
2944                     SPAGAIN;
2945
2946                     if (count > 0) {
2947                         int i = 0;
2948                         SV *arg;
2949
2950                         SP -= count - 1;
2951                         arg = SP[i++];
2952
2953                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2954                             arg = SvRV(arg);
2955                         }
2956
2957                         if (SvTYPE(arg) == SVt_PVGV) {
2958                             IO *io = GvIO((GV *)arg);
2959
2960                             ++filter_has_file;
2961
2962                             if (io) {
2963                                 tryrsfp = IoIFP(io);
2964                                 if (IoTYPE(io) == '|') {
2965                                     /* reading from a child process doesn't
2966                                        nest -- when returning from reading
2967                                        the inner module, the outer one is
2968                                        unreadable (closed?)  I've tried to
2969                                        save the gv to manage the lifespan of
2970                                        the pipe, but this didn't help. XXX */
2971                                     filter_child_proc = (GV *)arg;
2972                                     (void)SvREFCNT_inc(filter_child_proc);
2973                                 }
2974                                 else {
2975                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2976                                         PerlIO_close(IoOFP(io));
2977                                     }
2978                                     IoIFP(io) = Nullfp;
2979                                     IoOFP(io) = Nullfp;
2980                                 }
2981                             }
2982
2983                             if (i < count) {
2984                                 arg = SP[i++];
2985                             }
2986                         }
2987
2988                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2989                             filter_sub = arg;
2990                             (void)SvREFCNT_inc(filter_sub);
2991
2992                             if (i < count) {
2993                                 filter_state = SP[i];
2994                                 (void)SvREFCNT_inc(filter_state);
2995                             }
2996
2997                             if (tryrsfp == 0) {
2998                                 tryrsfp = PerlIO_open("/dev/null",
2999                                                       PERL_SCRIPT_MODE);
3000                             }
3001                         }
3002                     }
3003
3004                     PUTBACK;
3005                     FREETMPS;
3006                     LEAVE;
3007
3008                     if (tryrsfp) {
3009                         break;
3010                     }
3011
3012                     filter_has_file = 0;
3013                     if (filter_child_proc) {
3014                         SvREFCNT_dec(filter_child_proc);
3015                         filter_child_proc = 0;
3016                     }
3017                     if (filter_state) {
3018                         SvREFCNT_dec(filter_state);
3019                         filter_state = 0;
3020                     }
3021                     if (filter_sub) {
3022                         SvREFCNT_dec(filter_sub);
3023                         filter_sub = 0;
3024                     }
3025                 }
3026                 else {
3027                     char *dir = SvPVx(dirsv, n_a);
3028 #ifdef VMS
3029                     char *unixdir;
3030                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3031                         continue;
3032                     sv_setpv(namesv, unixdir);
3033                     sv_catpv(namesv, unixname);
3034 #else
3035                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3036 #endif
3037                     TAINT_PROPER("require");
3038                     tryname = SvPVX(namesv);
3039                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3040                     if (tryrsfp) {
3041                         if (tryname[0] == '.' && tryname[1] == '/')
3042                             tryname += 2;
3043                         break;
3044                     }
3045                 }
3046             }
3047         }
3048     }
3049     SAVECOPFILE(&PL_compiling);
3050     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3051     SvREFCNT_dec(namesv);
3052     if (!tryrsfp) {
3053         if (PL_op->op_type == OP_REQUIRE) {
3054             char *msgstr = name;
3055             if (namesv) {                       /* did we lookup @INC? */
3056                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3057                 SV *dirmsgsv = NEWSV(0, 0);
3058                 AV *ar = GvAVn(PL_incgv);
3059                 I32 i;
3060                 sv_catpvn(msg, " in @INC", 8);
3061                 if (instr(SvPVX(msg), ".h "))
3062                     sv_catpv(msg, " (change .h to .ph maybe?)");
3063                 if (instr(SvPVX(msg), ".ph "))
3064                     sv_catpv(msg, " (did you run h2ph?)");
3065                 sv_catpv(msg, " (@INC contains:");
3066                 for (i = 0; i <= AvFILL(ar); i++) {
3067                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3068                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3069                     sv_catsv(msg, dirmsgsv);
3070                 }
3071                 sv_catpvn(msg, ")", 1);
3072                 SvREFCNT_dec(dirmsgsv);
3073                 msgstr = SvPV_nolen(msg);
3074             }
3075             DIE(aTHX_ "Can't locate %s", msgstr);
3076         }
3077
3078         RETPUSHUNDEF;
3079     }
3080     else
3081         SETERRNO(0, SS$_NORMAL);
3082
3083     /* Assume success here to prevent recursive requirement. */
3084     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3085                    newSVpv(CopFILE(&PL_compiling), 0), 0 );
3086
3087     ENTER;
3088     SAVETMPS;
3089     lex_start(sv_2mortal(newSVpvn("",0)));
3090     SAVEGENERICSV(PL_rsfp_filters);
3091     PL_rsfp_filters = Nullav;
3092
3093     PL_rsfp = tryrsfp;
3094     SAVEHINTS();
3095     PL_hints = 0;
3096     SAVESPTR(PL_compiling.cop_warnings);
3097     if (PL_dowarn & G_WARN_ALL_ON)
3098         PL_compiling.cop_warnings = WARN_ALL ;
3099     else if (PL_dowarn & G_WARN_ALL_OFF)
3100         PL_compiling.cop_warnings = WARN_NONE ;
3101     else
3102         PL_compiling.cop_warnings = WARN_STD ;
3103
3104     if (filter_sub || filter_child_proc) {
3105         SV *datasv = filter_add(run_user_filter, Nullsv);
3106         IoLINES(datasv) = filter_has_file;
3107         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3108         IoTOP_GV(datasv) = (GV *)filter_state;
3109         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3110     }
3111
3112     /* switch to eval mode */
3113     push_return(PL_op->op_next);
3114     PUSHBLOCK(cx, CXt_EVAL, SP);
3115     PUSHEVAL(cx, name, Nullgv);
3116
3117     SAVECOPLINE(&PL_compiling);
3118     CopLINE_set(&PL_compiling, 0);
3119
3120     PUTBACK;
3121 #ifdef USE_THREADS
3122     MUTEX_LOCK(&PL_eval_mutex);
3123     if (PL_eval_owner && PL_eval_owner != thr)
3124         while (PL_eval_owner)
3125             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3126     PL_eval_owner = thr;
3127     MUTEX_UNLOCK(&PL_eval_mutex);
3128 #endif /* USE_THREADS */
3129     return DOCATCH(doeval(G_SCALAR, NULL));
3130 }
3131
3132 PP(pp_dofile)
3133 {
3134     return pp_require();
3135 }
3136
3137 PP(pp_entereval)
3138 {
3139     djSP;
3140     register PERL_CONTEXT *cx;
3141     dPOPss;
3142     I32 gimme = GIMME_V, was = PL_sub_generation;
3143     char tmpbuf[TYPE_DIGITS(long) + 12];
3144     char *safestr;
3145     STRLEN len;
3146     OP *ret;
3147
3148     if (!SvPV(sv,len) || !len)
3149         RETPUSHUNDEF;
3150     TAINT_PROPER("eval");
3151
3152     ENTER;
3153     lex_start(sv);
3154     SAVETMPS;
3155
3156     /* switch to eval mode */
3157
3158     SAVECOPFILE(&PL_compiling);
3159     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3160     CopFILE_set(&PL_compiling, tmpbuf+2);
3161     CopLINE_set(&PL_compiling, 1);
3162     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3163        deleting the eval's FILEGV from the stash before gv_check() runs
3164        (i.e. before run-time proper). To work around the coredump that
3165        ensues, we always turn GvMULTI_on for any globals that were
3166        introduced within evals. See force_ident(). GSAR 96-10-12 */
3167     safestr = savepv(tmpbuf);
3168     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3169     SAVEHINTS();
3170     PL_hints = PL_op->op_targ;
3171     SAVESPTR(PL_compiling.cop_warnings);
3172     if (!specialWARN(PL_compiling.cop_warnings)) {
3173         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3174         SAVEFREESV(PL_compiling.cop_warnings) ;
3175     }
3176
3177     push_return(PL_op->op_next);
3178     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3179     PUSHEVAL(cx, 0, Nullgv);
3180
3181     /* prepare to compile string */
3182
3183     if (PERLDB_LINE && PL_curstash != PL_debstash)
3184         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3185     PUTBACK;
3186 #ifdef USE_THREADS
3187     MUTEX_LOCK(&PL_eval_mutex);
3188     if (PL_eval_owner && PL_eval_owner != thr)
3189         while (PL_eval_owner)
3190             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3191     PL_eval_owner = thr;
3192     MUTEX_UNLOCK(&PL_eval_mutex);
3193 #endif /* USE_THREADS */
3194     ret = doeval(gimme, NULL);
3195     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3196         && ret != PL_op->op_next) {     /* Successive compilation. */
3197         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3198     }
3199     return DOCATCH(ret);
3200 }
3201
3202 PP(pp_leaveeval)
3203 {
3204     djSP;
3205     register SV **mark;
3206     SV **newsp;
3207     PMOP *newpm;
3208     I32 gimme;
3209     register PERL_CONTEXT *cx;
3210     OP *retop;
3211     U8 save_flags = PL_op -> op_flags;
3212     I32 optype;
3213
3214     POPBLOCK(cx,newpm);
3215     POPEVAL(cx);
3216     retop = pop_return();
3217
3218     TAINT_NOT;
3219     if (gimme == G_VOID)
3220         MARK = newsp;
3221     else if (gimme == G_SCALAR) {
3222         MARK = newsp + 1;
3223         if (MARK <= SP) {
3224             if (SvFLAGS(TOPs) & SVs_TEMP)
3225                 *MARK = TOPs;
3226             else
3227                 *MARK = sv_mortalcopy(TOPs);
3228         }
3229         else {
3230             MEXTEND(mark,0);
3231             *MARK = &PL_sv_undef;
3232         }
3233         SP = MARK;
3234     }
3235     else {
3236         /* in case LEAVE wipes old return values */
3237         for (mark = newsp + 1; mark <= SP; mark++) {
3238             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3239                 *mark = sv_mortalcopy(*mark);
3240                 TAINT_NOT;      /* Each item is independent */
3241             }
3242         }
3243     }
3244     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3245
3246     if (AvFILLp(PL_comppad_name) >= 0)
3247         free_closures();
3248
3249 #ifdef DEBUGGING
3250     assert(CvDEPTH(PL_compcv) == 1);
3251 #endif
3252     CvDEPTH(PL_compcv) = 0;
3253     lex_end();
3254
3255     if (optype == OP_REQUIRE &&
3256         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3257     {
3258         /* Unassume the success we assumed earlier. */
3259         char *name = cx->blk_eval.old_name;
3260         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3261         retop = Perl_die(aTHX_ "%s did not return a true value", name);
3262         /* die_where() did LEAVE, or we won't be here */
3263     }
3264     else {
3265         LEAVE;
3266         if (!(save_flags & OPf_SPECIAL))
3267             sv_setpv(ERRSV,"");
3268     }
3269
3270     RETURNOP(retop);
3271 }
3272
3273 PP(pp_entertry)
3274 {
3275     djSP;
3276     register PERL_CONTEXT *cx;
3277     I32 gimme = GIMME_V;
3278
3279     ENTER;
3280     SAVETMPS;
3281
3282     push_return(cLOGOP->op_other->op_next);
3283     PUSHBLOCK(cx, CXt_EVAL, SP);
3284     PUSHEVAL(cx, 0, 0);
3285     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3286
3287     PL_in_eval = EVAL_INEVAL;
3288     sv_setpv(ERRSV,"");
3289     PUTBACK;
3290     return DOCATCH(PL_op->op_next);
3291 }
3292
3293 PP(pp_leavetry)
3294 {
3295     djSP;
3296     register SV **mark;
3297     SV **newsp;
3298     PMOP *newpm;
3299     I32 gimme;
3300     register PERL_CONTEXT *cx;
3301     I32 optype;
3302
3303     POPBLOCK(cx,newpm);
3304     POPEVAL(cx);
3305     pop_return();
3306
3307     TAINT_NOT;
3308     if (gimme == G_VOID)
3309         SP = newsp;
3310     else if (gimme == G_SCALAR) {
3311         MARK = newsp + 1;
3312         if (MARK <= SP) {
3313             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3314                 *MARK = TOPs;
3315             else
3316                 *MARK = sv_mortalcopy(TOPs);
3317         }
3318         else {
3319             MEXTEND(mark,0);
3320             *MARK = &PL_sv_undef;
3321         }
3322         SP = MARK;
3323     }
3324     else {
3325         /* in case LEAVE wipes old return values */
3326         for (mark = newsp + 1; mark <= SP; mark++) {
3327             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3328                 *mark = sv_mortalcopy(*mark);
3329                 TAINT_NOT;      /* Each item is independent */
3330             }
3331         }
3332     }
3333     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3334
3335     LEAVE;
3336     sv_setpv(ERRSV,"");
3337     RETURN;
3338 }
3339
3340 STATIC void
3341 S_doparseform(pTHX_ SV *sv)
3342 {
3343     STRLEN len;
3344     register char *s = SvPV_force(sv, len);
3345     register char *send = s + len;
3346     register char *base;
3347     register I32 skipspaces = 0;
3348     bool noblank;
3349     bool repeat;
3350     bool postspace = FALSE;
3351     U16 *fops;
3352     register U16 *fpc;
3353     U16 *linepc;
3354     register I32 arg;
3355     bool ischop;
3356
3357     if (len == 0)
3358         Perl_croak(aTHX_ "Null picture in formline");
3359
3360     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3361     fpc = fops;
3362
3363     if (s < send) {
3364         linepc = fpc;
3365         *fpc++ = FF_LINEMARK;
3366         noblank = repeat = FALSE;
3367         base = s;
3368     }
3369
3370     while (s <= send) {
3371         switch (*s++) {
3372         default:
3373             skipspaces = 0;
3374             continue;
3375
3376         case '~':
3377             if (*s == '~') {
3378                 repeat = TRUE;
3379                 *s = ' ';
3380             }
3381             noblank = TRUE;
3382             s[-1] = ' ';
3383             /* FALL THROUGH */
3384         case ' ': case '\t':
3385             skipspaces++;
3386             continue;
3387
3388         case '\n': case 0:
3389             arg = s - base;
3390             skipspaces++;
3391             arg -= skipspaces;
3392             if (arg) {
3393                 if (postspace)
3394                     *fpc++ = FF_SPACE;
3395                 *fpc++ = FF_LITERAL;
3396                 *fpc++ = arg;
3397             }
3398             postspace = FALSE;
3399             if (s <= send)
3400                 skipspaces--;
3401             if (skipspaces) {
3402                 *fpc++ = FF_SKIP;
3403                 *fpc++ = skipspaces;
3404             }
3405             skipspaces = 0;
3406             if (s <= send)
3407                 *fpc++ = FF_NEWLINE;
3408             if (noblank) {
3409                 *fpc++ = FF_BLANK;
3410                 if (repeat)
3411                     arg = fpc - linepc + 1;
3412                 else
3413                     arg = 0;
3414                 *fpc++ = arg;
3415             }
3416             if (s < send) {
3417                 linepc = fpc;
3418                 *fpc++ = FF_LINEMARK;
3419                 noblank = repeat = FALSE;
3420                 base = s;
3421             }
3422             else
3423                 s++;
3424             continue;
3425
3426         case '@':
3427         case '^':
3428             ischop = s[-1] == '^';
3429
3430             if (postspace) {
3431                 *fpc++ = FF_SPACE;
3432                 postspace = FALSE;
3433             }
3434             arg = (s - base) - 1;
3435             if (arg) {
3436                 *fpc++ = FF_LITERAL;
3437                 *fpc++ = arg;
3438             }
3439
3440             base = s - 1;
3441             *fpc++ = FF_FETCH;
3442             if (*s == '*') {
3443                 s++;
3444                 *fpc++ = 0;
3445                 *fpc++ = FF_LINEGLOB;
3446             }
3447             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3448                 arg = ischop ? 512 : 0;
3449                 base = s - 1;
3450                 while (*s == '#')
3451                     s++;
3452                 if (*s == '.') {
3453                     char *f;
3454                     s++;
3455                     f = s;
3456                     while (*s == '#')
3457                         s++;
3458                     arg |= 256 + (s - f);
3459                 }
3460                 *fpc++ = s - base;              /* fieldsize for FETCH */
3461                 *fpc++ = FF_DECIMAL;
3462                 *fpc++ = arg;
3463             }
3464             else {
3465                 I32 prespace = 0;
3466                 bool ismore = FALSE;
3467
3468                 if (*s == '>') {
3469                     while (*++s == '>') ;
3470                     prespace = FF_SPACE;
3471                 }
3472                 else if (*s == '|') {
3473                     while (*++s == '|') ;
3474                     prespace = FF_HALFSPACE;
3475                     postspace = TRUE;
3476                 }
3477                 else {
3478                     if (*s == '<')
3479                         while (*++s == '<') ;
3480                     postspace = TRUE;
3481                 }
3482                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3483                     s += 3;
3484                     ismore = TRUE;
3485                 }
3486                 *fpc++ = s - base;              /* fieldsize for FETCH */
3487
3488                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3489
3490                 if (prespace)
3491                     *fpc++ = prespace;
3492                 *fpc++ = FF_ITEM;
3493                 if (ismore)
3494                     *fpc++ = FF_MORE;
3495                 if (ischop)
3496                     *fpc++ = FF_CHOP;
3497             }
3498             base = s;
3499             skipspaces = 0;
3500             continue;
3501         }
3502     }
3503     *fpc++ = FF_END;
3504
3505     arg = fpc - fops;
3506     { /* need to jump to the next word */
3507         int z;
3508         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3509         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3510         s = SvPVX(sv) + SvCUR(sv) + z;
3511     }
3512     Copy(fops, s, arg, U16);
3513     Safefree(fops);
3514     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3515     SvCOMPILED_on(sv);
3516 }
3517
3518 /*
3519  * The rest of this file was derived from source code contributed
3520  * by Tom Horsley.
3521  *
3522  * NOTE: this code was derived from Tom Horsley's qsort replacement
3523  * and should not be confused with the original code.
3524  */
3525
3526 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3527
3528    Permission granted to distribute under the same terms as perl which are
3529    (briefly):
3530
3531     This program is free software; you can redistribute it and/or modify
3532     it under the terms of either:
3533
3534         a) the GNU General Public License as published by the Free
3535         Software Foundation; either version 1, or (at your option) any
3536         later version, or
3537
3538         b) the "Artistic License" which comes with this Kit.
3539
3540    Details on the perl license can be found in the perl source code which
3541    may be located via the www.perl.com web page.
3542
3543    This is the most wonderfulest possible qsort I can come up with (and
3544    still be mostly portable) My (limited) tests indicate it consistently
3545    does about 20% fewer calls to compare than does the qsort in the Visual
3546    C++ library, other vendors may vary.
3547
3548    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3549    others I invented myself (or more likely re-invented since they seemed
3550    pretty obvious once I watched the algorithm operate for a while).
3551
3552    Most of this code was written while watching the Marlins sweep the Giants
3553    in the 1997 National League Playoffs - no Braves fans allowed to use this
3554    code (just kidding :-).
3555
3556    I realize that if I wanted to be true to the perl tradition, the only
3557    comment in this file would be something like:
3558
3559    ...they shuffled back towards the rear of the line. 'No, not at the
3560    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3561
3562    However, I really needed to violate that tradition just so I could keep
3563    track of what happens myself, not to mention some poor fool trying to
3564    understand this years from now :-).
3565 */
3566
3567 /* ********************************************************** Configuration */
3568
3569 #ifndef QSORT_ORDER_GUESS
3570 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3571 #endif
3572
3573 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3574    future processing - a good max upper bound is log base 2 of memory size
3575    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3576    safely be smaller than that since the program is taking up some space and
3577    most operating systems only let you grab some subset of contiguous
3578    memory (not to mention that you are normally sorting data larger than
3579    1 byte element size :-).
3580 */
3581 #ifndef QSORT_MAX_STACK
3582 #define QSORT_MAX_STACK 32
3583 #endif
3584
3585 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3586    Anything bigger and we use qsort. If you make this too small, the qsort
3587    will probably break (or become less efficient), because it doesn't expect
3588    the middle element of a partition to be the same as the right or left -
3589    you have been warned).
3590 */
3591 #ifndef QSORT_BREAK_EVEN
3592 #define QSORT_BREAK_EVEN 6
3593 #endif
3594
3595 /* ************************************************************* Data Types */
3596
3597 /* hold left and right index values of a partition waiting to be sorted (the
3598    partition includes both left and right - right is NOT one past the end or
3599    anything like that).
3600 */
3601 struct partition_stack_entry {
3602    int left;
3603    int right;
3604 #ifdef QSORT_ORDER_GUESS
3605    int qsort_break_even;
3606 #endif
3607 };
3608
3609 /* ******************************************************* Shorthand Macros */
3610
3611 /* Note that these macros will be used from inside the qsort function where
3612    we happen to know that the variable 'elt_size' contains the size of an
3613    array element and the variable 'temp' points to enough space to hold a
3614    temp element and the variable 'array' points to the array being sorted
3615    and 'compare' is the pointer to the compare routine.
3616
3617    Also note that there are very many highly architecture specific ways
3618    these might be sped up, but this is simply the most generally portable
3619    code I could think of.
3620 */
3621
3622 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3623 */
3624 #define qsort_cmp(elt1, elt2) \
3625    ((*compare)(aTHXo_ array[elt1], array[elt2]))
3626
3627 #ifdef QSORT_ORDER_GUESS
3628 #define QSORT_NOTICE_SWAP swapped++;
3629 #else
3630 #define QSORT_NOTICE_SWAP
3631 #endif
3632
3633 /* swaps contents of array elements elt1, elt2.
3634 */
3635 #define qsort_swap(elt1, elt2) \
3636    STMT_START { \
3637       QSORT_NOTICE_SWAP \
3638       temp = array[elt1]; \
3639       array[elt1] = array[elt2]; \
3640       array[elt2] = temp; \
3641    } STMT_END
3642
3643 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3644    elt3 and elt3 gets elt1.
3645 */
3646 #define qsort_rotate(elt1, elt2, elt3) \
3647    STMT_START { \
3648       QSORT_NOTICE_SWAP \
3649       temp = array[elt1]; \
3650       array[elt1] = array[elt2]; \
3651       array[elt2] = array[elt3]; \
3652       array[elt3] = temp; \
3653    } STMT_END
3654
3655 /* ************************************************************ Debug stuff */
3656
3657 #ifdef QSORT_DEBUG
3658
3659 static void
3660 break_here()
3661 {
3662    return; /* good place to set a breakpoint */
3663 }
3664
3665 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3666
3667 static void
3668 doqsort_all_asserts(
3669    void * array,
3670    size_t num_elts,
3671    size_t elt_size,
3672    int (*compare)(const void * elt1, const void * elt2),
3673    int pc_left, int pc_right, int u_left, int u_right)
3674 {
3675    int i;
3676
3677    qsort_assert(pc_left <= pc_right);
3678    qsort_assert(u_right < pc_left);
3679    qsort_assert(pc_right < u_left);
3680    for (i = u_right + 1; i < pc_left; ++i) {
3681       qsort_assert(qsort_cmp(i, pc_left) < 0);
3682    }
3683    for (i = pc_left; i < pc_right; ++i) {
3684       qsort_assert(qsort_cmp(i, pc_right) == 0);
3685    }
3686    for (i = pc_right + 1; i < u_left; ++i) {
3687       qsort_assert(qsort_cmp(pc_right, i) < 0);
3688    }
3689 }
3690
3691 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3692    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3693                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3694
3695 #else
3696
3697 #define qsort_assert(t) ((void)0)
3698
3699 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3700
3701 #endif
3702
3703 /* ****************************************************************** qsort */
3704
3705 STATIC void
3706 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3707 {
3708    register SV * temp;
3709
3710    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3711    int next_stack_entry = 0;
3712
3713    int part_left;
3714    int part_right;
3715 #ifdef QSORT_ORDER_GUESS
3716    int qsort_break_even;
3717    int swapped;
3718 #endif
3719
3720    /* Make sure we actually have work to do.
3721    */
3722    if (num_elts <= 1) {
3723       return;
3724    }
3725
3726    /* Setup the initial partition definition and fall into the sorting loop
3727    */
3728    part_left = 0;
3729    part_right = (int)(num_elts - 1);
3730 #ifdef QSORT_ORDER_GUESS
3731    qsort_break_even = QSORT_BREAK_EVEN;
3732 #else
3733 #define qsort_break_even QSORT_BREAK_EVEN
3734 #endif
3735    for ( ; ; ) {
3736       if ((part_right - part_left) >= qsort_break_even) {
3737          /* OK, this is gonna get hairy, so lets try to document all the
3738             concepts and abbreviations and variables and what they keep
3739             track of:
3740
3741             pc: pivot chunk - the set of array elements we accumulate in the
3742                 middle of the partition, all equal in value to the original
3743                 pivot element selected. The pc is defined by:
3744
3745                 pc_left - the leftmost array index of the pc
3746                 pc_right - the rightmost array index of the pc
3747
3748                 we start with pc_left == pc_right and only one element
3749                 in the pivot chunk (but it can grow during the scan).
3750
3751             u:  uncompared elements - the set of elements in the partition
3752                 we have not yet compared to the pivot value. There are two
3753                 uncompared sets during the scan - one to the left of the pc
3754                 and one to the right.
3755
3756                 u_right - the rightmost index of the left side's uncompared set
3757                 u_left - the leftmost index of the right side's uncompared set
3758
3759                 The leftmost index of the left sides's uncompared set
3760                 doesn't need its own variable because it is always defined
3761                 by the leftmost edge of the whole partition (part_left). The
3762                 same goes for the rightmost edge of the right partition
3763                 (part_right).
3764
3765                 We know there are no uncompared elements on the left once we
3766                 get u_right < part_left and no uncompared elements on the
3767                 right once u_left > part_right. When both these conditions
3768                 are met, we have completed the scan of the partition.
3769
3770                 Any elements which are between the pivot chunk and the
3771                 uncompared elements should be less than the pivot value on
3772                 the left side and greater than the pivot value on the right
3773                 side (in fact, the goal of the whole algorithm is to arrange
3774                 for that to be true and make the groups of less-than and
3775                 greater-then elements into new partitions to sort again).
3776
3777             As you marvel at the complexity of the code and wonder why it
3778             has to be so confusing. Consider some of the things this level
3779             of confusion brings:
3780
3781             Once I do a compare, I squeeze every ounce of juice out of it. I
3782             never do compare calls I don't have to do, and I certainly never
3783             do redundant calls.
3784
3785             I also never swap any elements unless I can prove there is a
3786             good reason. Many sort algorithms will swap a known value with
3787             an uncompared value just to get things in the right place (or
3788             avoid complexity :-), but that uncompared value, once it gets
3789             compared, may then have to be swapped again. A lot of the
3790             complexity of this code is due to the fact that it never swaps
3791             anything except compared values, and it only swaps them when the
3792             compare shows they are out of position.
3793          */
3794          int pc_left, pc_right;
3795          int u_right, u_left;
3796
3797          int s;
3798
3799          pc_left = ((part_left + part_right) / 2);
3800          pc_right = pc_left;
3801          u_right = pc_left - 1;
3802          u_left = pc_right + 1;
3803
3804          /* Qsort works best when the pivot value is also the median value
3805             in the partition (unfortunately you can't find the median value
3806             without first sorting :-), so to give the algorithm a helping
3807             hand, we pick 3 elements and sort them and use the median value
3808             of that tiny set as the pivot value.
3809
3810             Some versions of qsort like to use the left middle and right as
3811             the 3 elements to sort so they can insure the ends of the
3812             partition will contain values which will stop the scan in the
3813             compare loop, but when you have to call an arbitrarily complex
3814             routine to do a compare, its really better to just keep track of
3815             array index values to know when you hit the edge of the
3816             partition and avoid the extra compare. An even better reason to
3817             avoid using a compare call is the fact that you can drop off the
3818             edge of the array if someone foolishly provides you with an
3819             unstable compare function that doesn't always provide consistent
3820             results.
3821
3822             So, since it is simpler for us to compare the three adjacent
3823             elements in the middle of the partition, those are the ones we
3824             pick here (conveniently pointed at by u_right, pc_left, and
3825             u_left). The values of the left, center, and right elements
3826             are refered to as l c and r in the following comments.
3827          */
3828
3829 #ifdef QSORT_ORDER_GUESS
3830          swapped = 0;
3831 #endif
3832          s = qsort_cmp(u_right, pc_left);
3833          if (s < 0) {
3834             /* l < c */
3835             s = qsort_cmp(pc_left, u_left);
3836             /* if l < c, c < r - already in order - nothing to do */
3837             if (s == 0) {
3838                /* l < c, c == r - already in order, pc grows */
3839                ++pc_right;
3840                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3841             } else if (s > 0) {
3842                /* l < c, c > r - need to know more */
3843                s = qsort_cmp(u_right, u_left);
3844                if (s < 0) {
3845                   /* l < c, c > r, l < r - swap c & r to get ordered */
3846                   qsort_swap(pc_left, u_left);
3847                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3848                } else if (s == 0) {
3849                   /* l < c, c > r, l == r - swap c&r, grow pc */
3850                   qsort_swap(pc_left, u_left);
3851                   --pc_left;
3852                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3853                } else {
3854                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3855                   qsort_rotate(pc_left, u_right, u_left);
3856                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3857                }
3858             }
3859          } else if (s == 0) {
3860             /* l == c */
3861             s = qsort_cmp(pc_left, u_left);
3862             if (s < 0) {
3863                /* l == c, c < r - already in order, grow pc */
3864                --pc_left;
3865                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3866             } else if (s == 0) {
3867                /* l == c, c == r - already in order, grow pc both ways */
3868                --pc_left;
3869                ++pc_right;
3870                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3871             } else {
3872                /* l == c, c > r - swap l & r, grow pc */
3873                qsort_swap(u_right, u_left);
3874                ++pc_right;
3875                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3876             }
3877          } else {
3878             /* l > c */
3879             s = qsort_cmp(pc_left, u_left);
3880             if (s < 0) {
3881                /* l > c, c < r - need to know more */
3882                s = qsort_cmp(u_right, u_left);
3883                if (s < 0) {
3884                   /* l > c, c < r, l < r - swap l & c to get ordered */
3885                   qsort_swap(u_right, pc_left);
3886                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3887                } else if (s == 0) {
3888                   /* l > c, c < r, l == r - swap l & c, grow pc */
3889                   qsort_swap(u_right, pc_left);
3890                   ++pc_right;
3891                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3892                } else {
3893                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3894                   qsort_rotate(u_right, pc_left, u_left);
3895                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3896                }
3897             } else if (s == 0) {
3898                /* l > c, c == r - swap ends, grow pc */
3899                qsort_swap(u_right, u_left);
3900                --pc_left;
3901                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3902             } else {
3903                /* l > c, c > r - swap ends to get in order */
3904                qsort_swap(u_right, u_left);
3905                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3906             }
3907          }
3908          /* We now know the 3 middle elements have been compared and
3909             arranged in the desired order, so we can shrink the uncompared
3910             sets on both sides
3911          */
3912          --u_right;
3913          ++u_left;
3914          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3915
3916          /* The above massive nested if was the simple part :-). We now have
3917             the middle 3 elements ordered and we need to scan through the
3918             uncompared sets on either side, swapping elements that are on
3919             the wrong side or simply shuffling equal elements around to get
3920             all equal elements into the pivot chunk.
3921          */
3922
3923          for ( ; ; ) {
3924             int still_work_on_left;
3925             int still_work_on_right;
3926
3927             /* Scan the uncompared values on the left. If I find a value
3928                equal to the pivot value, move it over so it is adjacent to
3929                the pivot chunk and expand the pivot chunk. If I find a value
3930                less than the pivot value, then just leave it - its already
3931                on the correct side of the partition. If I find a greater
3932                value, then stop the scan.
3933             */
3934             while (still_work_on_left = (u_right >= part_left)) {
3935                s = qsort_cmp(u_right, pc_left);
3936                if (s < 0) {
3937                   --u_right;
3938                } else if (s == 0) {
3939                   --pc_left;
3940                   if (pc_left != u_right) {
3941                      qsort_swap(u_right, pc_left);
3942                   }
3943                   --u_right;
3944                } else {
3945                   break;
3946                }
3947                qsort_assert(u_right < pc_left);
3948                qsort_assert(pc_left <= pc_right);
3949                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3950                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3951             }
3952
3953             /* Do a mirror image scan of uncompared values on the right
3954             */
3955             while (still_work_on_right = (u_left <= part_right)) {
3956                s = qsort_cmp(pc_right, u_left);
3957                if (s < 0) {
3958                   ++u_left;
3959                } else if (s == 0) {
3960                   ++pc_right;
3961                   if (pc_right != u_left) {
3962                      qsort_swap(pc_right, u_left);
3963                   }
3964                   ++u_left;
3965                } else {
3966                   break;
3967                }
3968                qsort_assert(u_left > pc_right);
3969                qsort_assert(pc_left <= pc_right);
3970                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3971                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3972             }
3973
3974             if (still_work_on_left) {
3975                /* I know I have a value on the left side which needs to be
3976                   on the right side, but I need to know more to decide
3977                   exactly the best thing to do with it.
3978                */
3979                if (still_work_on_right) {
3980                   /* I know I have values on both side which are out of
3981                      position. This is a big win because I kill two birds
3982                      with one swap (so to speak). I can advance the
3983                      uncompared pointers on both sides after swapping both
3984                      of them into the right place.
3985                   */
3986                   qsort_swap(u_right, u_left);
3987                   --u_right;
3988                   ++u_left;
3989                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3990                } else {
3991                   /* I have an out of position value on the left, but the
3992                      right is fully scanned, so I "slide" the pivot chunk
3993                      and any less-than values left one to make room for the
3994                      greater value over on the right. If the out of position
3995                      value is immediately adjacent to the pivot chunk (there
3996                      are no less-than values), I can do that with a swap,
3997                      otherwise, I have to rotate one of the less than values
3998                      into the former position of the out of position value
3999                      and the right end of the pivot chunk into the left end
4000                      (got all that?).
4001                   */
4002                   --pc_left;
4003                   if (pc_left == u_right) {
4004                      qsort_swap(u_right, pc_right);
4005                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4006                   } else {
4007                      qsort_rotate(u_right, pc_left, pc_right);
4008                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4009                   }
4010                   --pc_right;
4011                   --u_right;
4012                }
4013             } else if (still_work_on_right) {
4014                /* Mirror image of complex case above: I have an out of
4015                   position value on the right, but the left is fully
4016                   scanned, so I need to shuffle things around to make room
4017                   for the right value on the left.
4018                */
4019                ++pc_right;
4020                if (pc_right == u_left) {
4021                   qsort_swap(u_left, pc_left);
4022                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4023                } else {
4024                   qsort_rotate(pc_right, pc_left, u_left);
4025                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4026                }
4027                ++pc_left;
4028                ++u_left;
4029             } else {
4030                /* No more scanning required on either side of partition,
4031                   break out of loop and figure out next set of partitions
4032                */
4033                break;
4034             }
4035          }
4036
4037          /* The elements in the pivot chunk are now in the right place. They
4038             will never move or be compared again. All I have to do is decide
4039             what to do with the stuff to the left and right of the pivot
4040             chunk.
4041
4042             Notes on the QSORT_ORDER_GUESS ifdef code:
4043
4044             1. If I just built these partitions without swapping any (or
4045                very many) elements, there is a chance that the elements are
4046                already ordered properly (being properly ordered will
4047                certainly result in no swapping, but the converse can't be
4048                proved :-).
4049
4050             2. A (properly written) insertion sort will run faster on
4051                already ordered data than qsort will.
4052
4053             3. Perhaps there is some way to make a good guess about
4054                switching to an insertion sort earlier than partition size 6
4055                (for instance - we could save the partition size on the stack
4056                and increase the size each time we find we didn't swap, thus
4057                switching to insertion sort earlier for partitions with a
4058                history of not swapping).
4059
4060             4. Naturally, if I just switch right away, it will make
4061                artificial benchmarks with pure ascending (or descending)
4062                data look really good, but is that a good reason in general?
4063                Hard to say...
4064          */
4065
4066 #ifdef QSORT_ORDER_GUESS
4067          if (swapped < 3) {
4068 #if QSORT_ORDER_GUESS == 1
4069             qsort_break_even = (part_right - part_left) + 1;
4070 #endif
4071 #if QSORT_ORDER_GUESS == 2
4072             qsort_break_even *= 2;
4073 #endif
4074 #if QSORT_ORDER_GUESS == 3
4075             int prev_break = qsort_break_even;
4076             qsort_break_even *= qsort_break_even;
4077             if (qsort_break_even < prev_break) {
4078                qsort_break_even = (part_right - part_left) + 1;
4079             }
4080 #endif
4081          } else {
4082             qsort_break_even = QSORT_BREAK_EVEN;
4083          }
4084 #endif
4085
4086          if (part_left < pc_left) {
4087             /* There are elements on the left which need more processing.
4088                Check the right as well before deciding what to do.
4089             */
4090             if (pc_right < part_right) {
4091                /* We have two partitions to be sorted. Stack the biggest one
4092                   and process the smallest one on the next iteration. This
4093                   minimizes the stack height by insuring that any additional
4094                   stack entries must come from the smallest partition which
4095                   (because it is smallest) will have the fewest
4096                   opportunities to generate additional stack entries.
4097                */
4098                if ((part_right - pc_right) > (pc_left - part_left)) {
4099                   /* stack the right partition, process the left */
4100                   partition_stack[next_stack_entry].left = pc_right + 1;
4101                   partition_stack[next_stack_entry].right = part_right;
4102 #ifdef QSORT_ORDER_GUESS
4103                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4104 #endif
4105                   part_right = pc_left - 1;
4106                } else {
4107                   /* stack the left partition, process the right */
4108                   partition_stack[next_stack_entry].left = part_left;
4109                   partition_stack[next_stack_entry].right = pc_left - 1;
4110 #ifdef QSORT_ORDER_GUESS
4111                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4112 #endif
4113                   part_left = pc_right + 1;
4114                }
4115                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4116                ++next_stack_entry;
4117             } else {
4118                /* The elements on the left are the only remaining elements
4119                   that need sorting, arrange for them to be processed as the
4120                   next partition.
4121                */
4122                part_right = pc_left - 1;
4123             }
4124          } else if (pc_right < part_right) {
4125             /* There is only one chunk on the right to be sorted, make it
4126                the new partition and loop back around.
4127             */
4128             part_left = pc_right + 1;
4129          } else {
4130             /* This whole partition wound up in the pivot chunk, so
4131                we need to get a new partition off the stack.
4132             */
4133             if (next_stack_entry == 0) {
4134                /* the stack is empty - we are done */
4135                break;
4136             }
4137             --next_stack_entry;
4138             part_left = partition_stack[next_stack_entry].left;
4139             part_right = partition_stack[next_stack_entry].right;
4140 #ifdef QSORT_ORDER_GUESS
4141             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4142 #endif
4143          }
4144       } else {
4145          /* This partition is too small to fool with qsort complexity, just
4146             do an ordinary insertion sort to minimize overhead.
4147          */
4148          int i;
4149          /* Assume 1st element is in right place already, and start checking
4150             at 2nd element to see where it should be inserted.
4151          */
4152          for (i = part_left + 1; i <= part_right; ++i) {
4153             int j;
4154             /* Scan (backwards - just in case 'i' is already in right place)
4155                through the elements already sorted to see if the ith element
4156                belongs ahead of one of them.
4157             */
4158             for (j = i - 1; j >= part_left; --j) {
4159                if (qsort_cmp(i, j) >= 0) {
4160                   /* i belongs right after j
4161                   */
4162                   break;
4163                }
4164             }
4165             ++j;
4166             if (j != i) {
4167                /* Looks like we really need to move some things
4168                */
4169                int k;
4170                temp = array[i];
4171                for (k = i - 1; k >= j; --k)
4172                   array[k + 1] = array[k];
4173                array[j] = temp;
4174             }
4175          }
4176
4177          /* That partition is now sorted, grab the next one, or get out
4178             of the loop if there aren't any more.
4179          */
4180
4181          if (next_stack_entry == 0) {
4182             /* the stack is empty - we are done */
4183             break;
4184          }
4185          --next_stack_entry;
4186          part_left = partition_stack[next_stack_entry].left;
4187          part_right = partition_stack[next_stack_entry].right;
4188 #ifdef QSORT_ORDER_GUESS
4189          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4190 #endif
4191       }
4192    }
4193
4194    /* Believe it or not, the array is sorted at this point! */
4195 }
4196
4197
4198 #ifdef PERL_OBJECT
4199 #undef this
4200 #define this pPerl
4201 #include "XSUB.h"
4202 #endif
4203
4204
4205 static I32
4206 sortcv(pTHXo_ SV *a, SV *b)
4207 {
4208     dTHR;
4209     I32 oldsaveix = PL_savestack_ix;
4210     I32 oldscopeix = PL_scopestack_ix;
4211     I32 result;
4212     GvSV(PL_firstgv) = a;
4213     GvSV(PL_secondgv) = b;
4214     PL_stack_sp = PL_stack_base;
4215     PL_op = PL_sortcop;
4216     CALLRUNOPS(aTHX);
4217     if (PL_stack_sp != PL_stack_base + 1)
4218         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4219     if (!SvNIOKp(*PL_stack_sp))
4220         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4221     result = SvIV(*PL_stack_sp);
4222     while (PL_scopestack_ix > oldscopeix) {
4223         LEAVE;
4224     }
4225     leave_scope(oldsaveix);
4226     return result;
4227 }
4228
4229 static I32
4230 sortcv_stacked(pTHXo_ SV *a, SV *b)
4231 {
4232     dTHR;
4233     I32 oldsaveix = PL_savestack_ix;
4234     I32 oldscopeix = PL_scopestack_ix;
4235     I32 result;
4236     AV *av;
4237
4238 #ifdef USE_THREADS
4239     av = (AV*)PL_curpad[0];
4240 #else
4241     av = GvAV(PL_defgv);
4242 #endif
4243
4244     if (AvMAX(av) < 1) {
4245         SV** ary = AvALLOC(av);
4246         if (AvARRAY(av) != ary) {
4247             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4248             SvPVX(av) = (char*)ary;
4249         }
4250         if (AvMAX(av) < 1) {
4251             AvMAX(av) = 1;
4252             Renew(ary,2,SV*);
4253             SvPVX(av) = (char*)ary;
4254         }
4255     }
4256     AvFILLp(av) = 1;
4257
4258     AvARRAY(av)[0] = a;
4259     AvARRAY(av)[1] = b;
4260     PL_stack_sp = PL_stack_base;
4261     PL_op = PL_sortcop;
4262     CALLRUNOPS(aTHX);
4263     if (PL_stack_sp != PL_stack_base + 1)
4264         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4265     if (!SvNIOKp(*PL_stack_sp))
4266         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4267     result = SvIV(*PL_stack_sp);
4268     while (PL_scopestack_ix > oldscopeix) {
4269         LEAVE;
4270     }
4271     leave_scope(oldsaveix);
4272     return result;
4273 }
4274
4275 static I32
4276 sortcv_xsub(pTHXo_ SV *a, SV *b)
4277 {
4278     dSP;
4279     I32 oldsaveix = PL_savestack_ix;
4280     I32 oldscopeix = PL_scopestack_ix;
4281     I32 result;
4282     CV *cv=(CV*)PL_sortcop;
4283
4284     SP = PL_stack_base;
4285     PUSHMARK(SP);
4286     EXTEND(SP, 2);
4287     *++SP = a;
4288     *++SP = b;
4289     PUTBACK;
4290     (void)(*CvXSUB(cv))(aTHXo_ cv);
4291     if (PL_stack_sp != PL_stack_base + 1)
4292         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4293     if (!SvNIOKp(*PL_stack_sp))
4294         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4295     result = SvIV(*PL_stack_sp);
4296     while (PL_scopestack_ix > oldscopeix) {
4297         LEAVE;
4298     }
4299     leave_scope(oldsaveix);
4300     return result;
4301 }
4302
4303
4304 static I32
4305 sv_ncmp(pTHXo_ SV *a, SV *b)
4306 {
4307     NV nv1 = SvNV(a);
4308     NV nv2 = SvNV(b);
4309     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4310 }
4311
4312 static I32
4313 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4314 {
4315     IV iv1 = SvIV(a);
4316     IV iv2 = SvIV(b);
4317     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4318 }
4319 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4320           *svp = Nullsv;                                \
4321           if (PL_amagic_generation) { \
4322             if (SvAMAGIC(left)||SvAMAGIC(right))\
4323                 *svp = amagic_call(left, \
4324                                    right, \
4325                                    CAT2(meth,_amg), \
4326                                    0); \
4327           } \
4328         } STMT_END
4329
4330 static I32
4331 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4332 {
4333     SV *tmpsv;
4334     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4335     if (tmpsv) {
4336         NV d;
4337
4338         if (SvIOK(tmpsv)) {
4339             I32 i = SvIVX(tmpsv);
4340             if (i > 0)
4341                return 1;
4342             return i? -1 : 0;
4343         }
4344         d = SvNV(tmpsv);
4345         if (d > 0)
4346            return 1;
4347         return d? -1 : 0;
4348      }
4349      return sv_ncmp(aTHXo_ a, b);
4350 }
4351
4352 static I32
4353 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4354 {
4355     SV *tmpsv;
4356     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4357     if (tmpsv) {
4358         NV d;
4359
4360         if (SvIOK(tmpsv)) {
4361             I32 i = SvIVX(tmpsv);
4362             if (i > 0)
4363                return 1;
4364             return i? -1 : 0;
4365         }
4366         d = SvNV(tmpsv);
4367         if (d > 0)
4368            return 1;
4369         return d? -1 : 0;
4370     }
4371     return sv_i_ncmp(aTHXo_ a, b);
4372 }
4373
4374 static I32
4375 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4376 {
4377     SV *tmpsv;
4378     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4379     if (tmpsv) {
4380         NV d;
4381
4382         if (SvIOK(tmpsv)) {
4383             I32 i = SvIVX(tmpsv);
4384             if (i > 0)
4385                return 1;
4386             return i? -1 : 0;
4387         }
4388         d = SvNV(tmpsv);
4389         if (d > 0)
4390            return 1;
4391         return d? -1 : 0;
4392     }
4393     return sv_cmp(str1, str2);
4394 }
4395
4396 static I32
4397 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4398 {
4399     SV *tmpsv;
4400     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4401     if (tmpsv) {
4402         NV d;
4403
4404         if (SvIOK(tmpsv)) {
4405             I32 i = SvIVX(tmpsv);
4406             if (i > 0)
4407                return 1;
4408             return i? -1 : 0;
4409         }
4410         d = SvNV(tmpsv);
4411         if (d > 0)
4412            return 1;
4413         return d? -1 : 0;
4414     }
4415     return sv_cmp_locale(str1, str2);
4416 }
4417
4418 static I32
4419 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4420 {
4421     SV *datasv = FILTER_DATA(idx);
4422     int filter_has_file = IoLINES(datasv);
4423     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4424     SV *filter_state = (SV *)IoTOP_GV(datasv);
4425     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4426     int len = 0;
4427
4428     /* I was having segfault trouble under Linux 2.2.5 after a
4429        parse error occured.  (Had to hack around it with a test
4430        for PL_error_count == 0.)  Solaris doesn't segfault --
4431        not sure where the trouble is yet.  XXX */
4432
4433     if (filter_has_file) {
4434         len = FILTER_READ(idx+1, buf_sv, maxlen);
4435     }
4436
4437     if (filter_sub && len >= 0) {
4438         djSP;
4439         int count;
4440
4441         ENTER;
4442         SAVE_DEFSV;
4443         SAVETMPS;
4444         EXTEND(SP, 2);
4445
4446         DEFSV = buf_sv;
4447         PUSHMARK(SP);
4448         PUSHs(sv_2mortal(newSViv(maxlen)));
4449         if (filter_state) {
4450             PUSHs(filter_state);
4451         }
4452         PUTBACK;
4453         count = call_sv(filter_sub, G_SCALAR);
4454         SPAGAIN;
4455
4456         if (count > 0) {
4457             SV *out = POPs;
4458             if (SvOK(out)) {
4459                 len = SvIV(out);
4460             }
4461         }
4462
4463         PUTBACK;
4464         FREETMPS;
4465         LEAVE;
4466     }
4467
4468     if (len <= 0) {
4469         IoLINES(datasv) = 0;
4470         if (filter_child_proc) {
4471             SvREFCNT_dec(filter_child_proc);
4472             IoFMT_GV(datasv) = Nullgv;
4473         }
4474         if (filter_state) {
4475             SvREFCNT_dec(filter_state);
4476             IoTOP_GV(datasv) = Nullgv;
4477         }
4478         if (filter_sub) {
4479             SvREFCNT_dec(filter_sub);
4480             IoBOTTOM_GV(datasv) = Nullgv;
4481         }
4482         filter_del(run_user_filter);
4483     }
4484
4485     return len;
4486 }
4487
4488 #ifdef PERL_OBJECT
4489
4490 static I32
4491 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4492 {
4493     return sv_cmp_locale(str1, str2);
4494 }
4495
4496 static I32
4497 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4498 {
4499     return sv_cmp(str1, str2);
4500 }
4501
4502 #endif /* PERL_OBJECT */