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