pp_ctl.c

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