pp_ctl.c

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