pp_ctl.c

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