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