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