Re: bleadperl doesn't compile
[p5sagit/p5-mst-13.2.git] / perlio.c
1 /*
2  * perlio.c Copyright (c) 1996-2001, Nick Ing-Simmons You may distribute
3  * under the terms of either the GNU General Public License or the
4  * Artistic License, as specified in the README file.
5  */
6
7 /*
8  * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
9  * at the dispatch tables, even when we do not need it for other reasons.
10  * Invent a dSYS macro to abstract this out
11  */
12 #ifdef PERL_IMPLICIT_SYS
13 #define dSYS dTHX
14 #else
15 #define dSYS dNOOP
16 #endif
17
18 #define VOIDUSED 1
19 #ifdef PERL_MICRO
20 #   include "uconfig.h"
21 #else
22 #   include "config.h"
23 #endif
24
25 #define PERLIO_NOT_STDIO 0
26 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
27 /*
28  * #define PerlIO FILE
29  */
30 #endif
31 /*
32  * This file provides those parts of PerlIO abstraction
33  * which are not #defined in perlio.h.
34  * Which these are depends on various Configure #ifdef's
35  */
36
37 #include "EXTERN.h"
38 #define PERL_IN_PERLIO_C
39 #include "perl.h"
40
41 #ifdef PERL_IMPLICIT_CONTEXT
42 #undef dSYS
43 #define dSYS dTHX
44 #endif
45
46 #include "XSUB.h"
47
48 int
49 perlsio_binmode(FILE *fp, int iotype, int mode)
50 {
51     /*
52      * This used to be contents of do_binmode in doio.c
53      */
54 #ifdef DOSISH
55 #  if defined(atarist) || defined(__MINT__)
56     if (!fflush(fp)) {
57         if (mode & O_BINARY)
58             ((FILE *) fp)->_flag |= _IOBIN;
59         else
60             ((FILE *) fp)->_flag &= ~_IOBIN;
61         return 1;
62     }
63     return 0;
64 #  else
65     dTHX;
66 #ifdef NETWARE
67     if (PerlLIO_setmode(fp, mode) != -1) {
68 #else
69     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
70 #endif
71 #    if defined(WIN32) && defined(__BORLANDC__)
72         /*
73          * The translation mode of the stream is maintained independent of
74          * the translation mode of the fd in the Borland RTL (heavy
75          * digging through their runtime sources reveal).  User has to set
76          * the mode explicitly for the stream (though they don't document
77          * this anywhere). GSAR 97-5-24
78          */
79         fseek(fp, 0L, 0);
80         if (mode & O_BINARY)
81             fp->flags |= _F_BIN;
82         else
83             fp->flags &= ~_F_BIN;
84 #    endif
85         return 1;
86     }
87     else
88         return 0;
89 #  endif
90 #else
91 #  if defined(USEMYBINMODE)
92     dTHX;
93     if (my_binmode(fp, iotype, mode) != FALSE)
94         return 1;
95     else
96         return 0;
97 #  else
98     return 1;
99 #  endif
100 #endif
101 }
102
103 #ifndef O_ACCMODE
104 #define O_ACCMODE 3             /* Assume traditional implementation */
105 #endif
106
107 int
108 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
109 {
110     int result = rawmode & O_ACCMODE;
111     int ix = 0;
112     int ptype;
113     switch (result) {
114     case O_RDONLY:
115         ptype = IoTYPE_RDONLY;
116         break;
117     case O_WRONLY:
118         ptype = IoTYPE_WRONLY;
119         break;
120     case O_RDWR:
121     default:
122         ptype = IoTYPE_RDWR;
123         break;
124     }
125     if (writing)
126         *writing = (result != O_RDONLY);
127
128     if (result == O_RDONLY) {
129         mode[ix++] = 'r';
130     }
131 #ifdef O_APPEND
132     else if (rawmode & O_APPEND) {
133         mode[ix++] = 'a';
134         if (result != O_WRONLY)
135             mode[ix++] = '+';
136     }
137 #endif
138     else {
139         if (result == O_WRONLY)
140             mode[ix++] = 'w';
141         else {
142             mode[ix++] = 'r';
143             mode[ix++] = '+';
144         }
145     }
146     if (rawmode & O_BINARY)
147         mode[ix++] = 'b';
148     mode[ix] = '\0';
149     return ptype;
150 }
151
152 #ifndef PERLIO_LAYERS
153 int
154 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
155 {
156     if (!names || !*names || strEQ(names, ":crlf") || strEQ(names, ":raw")) {
157         return 0;
158     }
159     Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
160     /*
161      * NOTREACHED
162      */
163     return -1;
164 }
165
166 void
167 PerlIO_destruct(pTHX)
168 {
169 }
170
171 int
172 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
173 {
174 #ifdef USE_SFIO
175     return 1;
176 #else
177     return perlsio_binmode(fp, iotype, mode);
178 #endif
179 }
180
181 PerlIO *
182 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
183 {
184 #ifndef PERL_MICRO
185     if (f) {
186         int fd = PerlLIO_dup(PerlIO_fileno(f));
187         if (fd >= 0) {
188             char mode[8];
189             int omode = fcntl(fd, F_GETFL);
190             PerlIO_intmode2str(omode,mode,NULL);
191             /* the r+ is a hack */
192             return PerlIO_fdopen(fd, mode);
193         }
194         return NULL;
195     }
196     else {
197         SETERRNO(EBADF, SS$_IVCHAN);
198     }
199 #endif
200     return NULL;
201 }
202
203
204 /*
205  * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
206  */
207
208 PerlIO *
209 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
210              int imode, int perm, PerlIO *old, int narg, SV **args)
211 {
212     if (narg) {
213         if (narg > 1) {
214             Perl_croak(aTHX_ "More than one argument to open");
215         }
216         if (*args == &PL_sv_undef)
217             return PerlIO_tmpfile();
218         else {
219             char *name = SvPV_nolen(*args);
220             if (*mode == '#') {
221                 fd = PerlLIO_open3(name, imode, perm);
222                 if (fd >= 0)
223                     return PerlIO_fdopen(fd, (char *) mode + 1);
224             }
225             else if (old) {
226                 return PerlIO_reopen(name, mode, old);
227             }
228             else {
229                 return PerlIO_open(name, mode);
230             }
231         }
232     }
233     else {
234         return PerlIO_fdopen(fd, (char *) mode);
235     }
236     return NULL;
237 }
238
239 XS(XS_PerlIO__Layer__find)
240 {
241     dXSARGS;
242     if (items < 2)
243         Perl_croak(aTHX_ "Usage class->find(name[,load])");
244     else {
245         char *name = SvPV_nolen(ST(1));
246         ST(0) = (strEQ(name, "crlf")
247                  || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
248         XSRETURN(1);
249     }
250 }
251
252
253 void
254 Perl_boot_core_PerlIO(pTHX)
255 {
256     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
257 }
258
259 #endif
260
261
262 #ifdef PERLIO_IS_STDIO
263
264 void
265 PerlIO_init(pTHX)
266 {
267     /*
268      * Does nothing (yet) except force this file to be included in perl
269      * binary. That allows this file to force inclusion of other functions
270      * that may be required by loadable extensions e.g. for
271      * FileHandle::tmpfile
272      */
273 }
274
275 #undef PerlIO_tmpfile
276 PerlIO *
277 PerlIO_tmpfile(void)
278 {
279     return tmpfile();
280 }
281
282 #else                           /* PERLIO_IS_STDIO */
283
284 #ifdef USE_SFIO
285
286 #undef HAS_FSETPOS
287 #undef HAS_FGETPOS
288
289 /*
290  * This section is just to make sure these functions get pulled in from
291  * libsfio.a
292  */
293
294 #undef PerlIO_tmpfile
295 PerlIO *
296 PerlIO_tmpfile(void)
297 {
298     return sftmp(0);
299 }
300
301 void
302 PerlIO_init(pTHX)
303 {
304     /*
305      * Force this file to be included in perl binary. Which allows this
306      * file to force inclusion of other functions that may be required by
307      * loadable extensions e.g. for FileHandle::tmpfile
308      */
309
310     /*
311      * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
312      * results in a lot of lseek()s to regular files and lot of small
313      * writes to pipes.
314      */
315     sfset(sfstdout, SF_SHARE, 0);
316 }
317
318 PerlIO *
319 PerlIO_importFILE(FILE *stdio, int fl)
320 {
321     int fd = fileno(stdio);
322     PerlIO *r = PerlIO_fdopen(fd, "r+");
323     return r;
324 }
325
326 FILE *
327 PerlIO_findFILE(PerlIO *pio)
328 {
329     int fd = PerlIO_fileno(pio);
330     FILE *f = fdopen(fd, "r+");
331     PerlIO_flush(pio);
332     if (!f && errno == EINVAL)
333         f = fdopen(fd, "w");
334     if (!f && errno == EINVAL)
335         f = fdopen(fd, "r");
336     return f;
337 }
338
339
340 #else                           /* USE_SFIO */
341 /*======================================================================================*/
342 /*
343  * Implement all the PerlIO interface ourselves.
344  */
345
346 #include "perliol.h"
347
348 /*
349  * We _MUST_ have <unistd.h> if we are using lseek() and may have large
350  * files
351  */
352 #ifdef I_UNISTD
353 #include <unistd.h>
354 #endif
355 #ifdef HAS_MMAP
356 #include <sys/mman.h>
357 #endif
358
359
360 void PerlIO_debug(const char *fmt, ...)
361     __attribute__ ((format(__printf__, 1, 2)));
362
363 void
364 PerlIO_debug(const char *fmt, ...)
365 {
366     static int dbg = 0;
367     va_list ap;
368     dSYS;
369     va_start(ap, fmt);
370     if (!dbg) {
371         char *s = PerlEnv_getenv("PERLIO_DEBUG");
372         if (s && *s)
373             dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
374         else
375             dbg = -1;
376     }
377     if (dbg > 0) {
378         dTHX;
379 #ifdef USE_ITHREADS
380         /* Use fixed buffer as sv_catpvf etc. needs SVs */
381         char buffer[1024];
382         char *s;
383         STRLEN len;
384         s = CopFILE(PL_curcop);
385         if (!s)
386             s = "(none)";
387         sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
388         len = strlen(buffer);
389         vsprintf(buffer+len, fmt, ap);
390         PerlLIO_write(dbg, buffer, strlen(buffer));
391 #else
392         SV *sv = newSVpvn("", 0);
393         char *s;
394         STRLEN len;
395         s = CopFILE(PL_curcop);
396         if (!s)
397             s = "(none)";
398         Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
399                        (IV) CopLINE(PL_curcop));
400         Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
401
402         s = SvPV(sv, len);
403         PerlLIO_write(dbg, s, len);
404         SvREFCNT_dec(sv);
405 #endif
406     }
407     va_end(ap);
408 }
409
410 /*--------------------------------------------------------------------------------------*/
411
412 /*
413  * Inner level routines
414  */
415
416 /*
417  * Table of pointers to the PerlIO structs (malloc'ed)
418  */
419 #define PERLIO_TABLE_SIZE 64
420
421 PerlIO *
422 PerlIO_allocate(pTHX)
423 {
424     /*
425      * Find a free slot in the table, allocating new table as necessary
426      */
427     PerlIO **last;
428     PerlIO *f;
429     last = &PL_perlio;
430     while ((f = *last)) {
431         int i;
432         last = (PerlIO **) (f);
433         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
434             if (!*++f) {
435                 return f;
436             }
437         }
438     }
439     Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
440     if (!f) {
441         return NULL;
442     }
443     *last = f;
444     return f + 1;
445 }
446
447 #undef PerlIO_fdupopen
448 PerlIO *
449 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
450 {
451     if (f && *f) {
452         PerlIO_funcs *tab = PerlIOBase(f)->tab;
453         PerlIO *new;
454         PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
455         new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
456         return new;
457     }
458     else {
459         SETERRNO(EBADF, SS$_IVCHAN);
460         return NULL;
461     }
462 }
463
464 void
465 PerlIO_cleantable(pTHX_ PerlIO **tablep)
466 {
467     PerlIO *table = *tablep;
468     if (table) {
469         int i;
470         PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
471         for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
472             PerlIO *f = table + i;
473             if (*f) {
474                 PerlIO_close(f);
475             }
476         }
477         Safefree(table);
478         *tablep = NULL;
479     }
480 }
481
482
483 PerlIO_list_t *
484 PerlIO_list_alloc(pTHX)
485 {
486     PerlIO_list_t *list;
487     Newz('L', list, 1, PerlIO_list_t);
488     list->refcnt = 1;
489     return list;
490 }
491
492 void
493 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
494 {
495     if (list) {
496         if (--list->refcnt == 0) {
497             if (list->array) {
498                 IV i;
499                 for (i = 0; i < list->cur; i++) {
500                     if (list->array[i].arg)
501                         SvREFCNT_dec(list->array[i].arg);
502                 }
503                 Safefree(list->array);
504             }
505             Safefree(list);
506         }
507     }
508 }
509
510 void
511 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
512 {
513     PerlIO_pair_t *p;
514     if (list->cur >= list->len) {
515         list->len += 8;
516         if (list->array)
517             Renew(list->array, list->len, PerlIO_pair_t);
518         else
519             New('l', list->array, list->len, PerlIO_pair_t);
520     }
521     p = &(list->array[list->cur++]);
522     p->funcs = funcs;
523     if ((p->arg = arg)) {
524         SvREFCNT_inc(arg);
525     }
526 }
527
528 PerlIO_list_t *
529 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
530 {
531     PerlIO_list_t *list = (PerlIO_list_t *) NULL;
532     if (proto) {
533         int i;
534         list = PerlIO_list_alloc(aTHX);
535         for (i=0; i < proto->cur; i++) {
536             SV *arg = Nullsv;
537             if (proto->array[i].arg)
538                 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
539             PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
540         }
541     }
542     return list;
543 }
544
545 void
546 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
547 {
548 #ifdef USE_ITHREADS
549     PerlIO **table = &proto->Iperlio;
550     PerlIO *f;
551     PL_perlio = NULL;
552     PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
553     PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
554     PerlIO_allocate(aTHX); /* root slot is never used */
555     PerlIO_debug("Clone %p from %p\n",aTHX,proto);
556     while ((f = *table)) {
557             int i;
558             table = (PerlIO **) (f++);
559             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
560                 if (*f) {
561                     (void) fp_dup(f, 0, param);
562                 }
563                 f++;
564             }
565         }
566 #endif
567 }
568
569 void
570 PerlIO_destruct(pTHX)
571 {
572     PerlIO **table = &PL_perlio;
573     PerlIO *f;
574 #ifdef USE_ITHREADS
575     PerlIO_debug("Destruct %p\n",aTHX);
576 #endif
577     while ((f = *table)) {
578         int i;
579         table = (PerlIO **) (f++);
580         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
581             PerlIO *x = f;
582             PerlIOl *l;
583             while ((l = *x)) {
584                 if (l->tab->kind & PERLIO_K_DESTRUCT) {
585                     PerlIO_debug("Destruct popping %s\n", l->tab->name);
586                     PerlIO_flush(x);
587                     PerlIO_pop(aTHX_ x);
588                 }
589                 else {
590                     x = PerlIONext(x);
591                 }
592             }
593             f++;
594         }
595     }
596     PerlIO_list_free(aTHX_ PL_known_layers);
597     PL_known_layers = NULL;
598     PerlIO_list_free(aTHX_ PL_def_layerlist);
599     PL_def_layerlist = NULL;
600 }
601
602 void
603 PerlIO_pop(pTHX_ PerlIO *f)
604 {
605     PerlIOl *l = *f;
606     if (l) {
607         PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
608         if (l->tab->Popped) {
609             /*
610              * If popped returns non-zero do not free its layer structure
611              * it has either done so itself, or it is shared and still in
612              * use
613              */
614             if ((*l->tab->Popped) (aTHX_ f) != 0)
615                 return;
616         }
617         *f = l->next;;
618         Safefree(l);
619     }
620 }
621
622 /*--------------------------------------------------------------------------------------*/
623 /*
624  * XS Interface for perl code
625  */
626
627 PerlIO_funcs *
628 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
629 {
630     IV i;
631     if ((SSize_t) len <= 0)
632         len = strlen(name);
633     for (i = 0; i < PL_known_layers->cur; i++) {
634         PerlIO_funcs *f = PL_known_layers->array[i].funcs;
635         if (memEQ(f->name, name, len)) {
636             PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
637             return f;
638         }
639     }
640     if (load && PL_subname && PL_def_layerlist
641         && PL_def_layerlist->cur >= 2) {
642         SV *pkgsv = newSVpvn("PerlIO", 6);
643         SV *layer = newSVpvn(name, len);
644         ENTER;
645         /*
646          * The two SVs are magically freed by load_module
647          */
648         Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
649         LEAVE;
650         return PerlIO_find_layer(aTHX_ name, len, 0);
651     }
652     PerlIO_debug("Cannot find %.*s\n", (int) len, name);
653     return NULL;
654 }
655
656 #ifdef USE_ATTRIBUTES_FOR_PERLIO
657
658 static int
659 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
660 {
661     if (SvROK(sv)) {
662         IO *io = GvIOn((GV *) SvRV(sv));
663         PerlIO *ifp = IoIFP(io);
664         PerlIO *ofp = IoOFP(io);
665         Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
666     }
667     return 0;
668 }
669
670 static int
671 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
672 {
673     if (SvROK(sv)) {
674         IO *io = GvIOn((GV *) SvRV(sv));
675         PerlIO *ifp = IoIFP(io);
676         PerlIO *ofp = IoOFP(io);
677         Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
678     }
679     return 0;
680 }
681
682 static int
683 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
684 {
685     Perl_warn(aTHX_ "clear %" SVf, sv);
686     return 0;
687 }
688
689 static int
690 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
691 {
692     Perl_warn(aTHX_ "free %" SVf, sv);
693     return 0;
694 }
695
696 MGVTBL perlio_vtab = {
697     perlio_mg_get,
698     perlio_mg_set,
699     NULL,                       /* len */
700     perlio_mg_clear,
701     perlio_mg_free
702 };
703
704 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
705 {
706     dXSARGS;
707     SV *sv = SvRV(ST(1));
708     AV *av = newAV();
709     MAGIC *mg;
710     int count = 0;
711     int i;
712     sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
713     SvRMAGICAL_off(sv);
714     mg = mg_find(sv, PERL_MAGIC_ext);
715     mg->mg_virtual = &perlio_vtab;
716     mg_magical(sv);
717     Perl_warn(aTHX_ "attrib %" SVf, sv);
718     for (i = 2; i < items; i++) {
719         STRLEN len;
720         const char *name = SvPV(ST(i), len);
721         SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
722         if (layer) {
723             av_push(av, SvREFCNT_inc(layer));
724         }
725         else {
726             ST(count) = ST(i);
727             count++;
728         }
729     }
730     SvREFCNT_dec(av);
731     XSRETURN(count);
732 }
733
734 #endif                          /* USE_ATTIBUTES_FOR_PERLIO */
735
736 SV *
737 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
738 {
739     HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
740     SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
741     return sv;
742 }
743
744 XS(XS_PerlIO__Layer__find)
745 {
746     dXSARGS;
747     if (items < 2)
748         Perl_croak(aTHX_ "Usage class->find(name[,load])");
749     else {
750         STRLEN len = 0;
751         char *name = SvPV(ST(1), len);
752         bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
753         PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
754         ST(0) =
755             (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
756             &PL_sv_undef;
757         XSRETURN(1);
758     }
759 }
760
761 void
762 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
763 {
764     if (!PL_known_layers)
765         PL_known_layers = PerlIO_list_alloc(aTHX);
766     PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
767     PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
768 }
769
770 int
771 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
772 {
773     if (names) {
774         const char *s = names;
775         while (*s) {
776             while (isSPACE(*s) || *s == ':')
777                 s++;
778             if (*s) {
779                 STRLEN llen = 0;
780                 const char *e = s;
781                 const char *as = Nullch;
782                 STRLEN alen = 0;
783                 if (!isIDFIRST(*s)) {
784                     /*
785                      * Message is consistent with how attribute lists are
786                      * passed. Even though this means "foo : : bar" is
787                      * seen as an invalid separator character.
788                      */
789                     char q = ((*s == '\'') ? '"' : '\'');
790                     Perl_warn(aTHX_
791                               "perlio: invalid separator character %c%c%c in layer specification list %s",
792                               q, *s, q, s);
793                     return -1;
794                 }
795                 do {
796                     e++;
797                 } while (isALNUM(*e));
798                 llen = e - s;
799                 if (*e == '(') {
800                     int nesting = 1;
801                     as = ++e;
802                     while (nesting) {
803                         switch (*e++) {
804                         case ')':
805                             if (--nesting == 0)
806                                 alen = (e - 1) - as;
807                             break;
808                         case '(':
809                             ++nesting;
810                             break;
811                         case '\\':
812                             /*
813                              * It's a nul terminated string, not allowed
814                              * to \ the terminating null. Anything other
815                              * character is passed over.
816                              */
817                             if (*e++) {
818                                 break;
819                             }
820                             /*
821                              * Drop through
822                              */
823                         case '\0':
824                             e--;
825                             Perl_warn(aTHX_
826                                       "perlio: argument list not closed for layer \"%.*s\"",
827                                       (int) (e - s), s);
828                             return -1;
829                         default:
830                             /*
831                              * boring.
832                              */
833                             break;
834                         }
835                     }
836                 }
837                 if (e > s) {
838                     PerlIO_funcs *layer =
839                         PerlIO_find_layer(aTHX_ s, llen, 1);
840                     if (layer) {
841                         PerlIO_list_push(aTHX_ av, layer,
842                                          (as) ? newSVpvn(as,
843                                                          alen) :
844                                          &PL_sv_undef);
845                     }
846                     else {
847                         Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",
848                                   (int) llen, s);
849                         return -1;
850                     }
851                 }
852                 s = e;
853             }
854         }
855     }
856     return 0;
857 }
858
859 void
860 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
861 {
862     PerlIO_funcs *tab = &PerlIO_perlio;
863 #ifdef PERLIO_USING_CRLF
864     tab = &PerlIO_crlf;
865 #else
866     if (PerlIO_stdio.Set_ptrcnt)
867         tab = &PerlIO_stdio;
868 #endif
869     PerlIO_debug("Pushing %s\n", tab->name);
870     PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
871                      &PL_sv_undef);
872 }
873
874 SV *
875 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
876 {
877     return av->array[n].arg;
878 }
879
880 PerlIO_funcs *
881 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
882 {
883     if (n >= 0 && n < av->cur) {
884         PerlIO_debug("Layer %" IVdf " is %s\n", n,
885                      av->array[n].funcs->name);
886         return av->array[n].funcs;
887     }
888     if (!def)
889         Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
890     return def;
891 }
892
893 PerlIO_list_t *
894 PerlIO_default_layers(pTHX)
895 {
896     if (!PL_def_layerlist) {
897         const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
898         PerlIO_funcs *osLayer = &PerlIO_unix;
899         PL_def_layerlist = PerlIO_list_alloc(aTHX);
900         PerlIO_define_layer(aTHX_ & PerlIO_unix);
901 #if defined(WIN32) && !defined(UNDER_CE)
902         PerlIO_define_layer(aTHX_ & PerlIO_win32);
903 #if 0
904         osLayer = &PerlIO_win32;
905 #endif
906 #endif
907         PerlIO_define_layer(aTHX_ & PerlIO_raw);
908         PerlIO_define_layer(aTHX_ & PerlIO_perlio);
909         PerlIO_define_layer(aTHX_ & PerlIO_stdio);
910         PerlIO_define_layer(aTHX_ & PerlIO_crlf);
911 #ifdef HAS_MMAP
912         PerlIO_define_layer(aTHX_ & PerlIO_mmap);
913 #endif
914         PerlIO_define_layer(aTHX_ & PerlIO_utf8);
915         PerlIO_define_layer(aTHX_ & PerlIO_byte);
916         PerlIO_list_push(aTHX_ PL_def_layerlist,
917                          PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
918                          &PL_sv_undef);
919         if (s) {
920             PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
921         }
922         else {
923             PerlIO_default_buffer(aTHX_ PL_def_layerlist);
924         }
925     }
926     if (PL_def_layerlist->cur < 2) {
927         PerlIO_default_buffer(aTHX_ PL_def_layerlist);
928     }
929     return PL_def_layerlist;
930 }
931
932 void
933 Perl_boot_core_PerlIO(pTHX)
934 {
935 #ifdef USE_ATTRIBUTES_FOR_PERLIO
936     newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
937           __FILE__);
938 #endif
939     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
940 }
941
942 PerlIO_funcs *
943 PerlIO_default_layer(pTHX_ I32 n)
944 {
945     PerlIO_list_t *av = PerlIO_default_layers(aTHX);
946     if (n < 0)
947         n += av->cur;
948     return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio);
949 }
950
951 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
952 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
953
954 void
955 PerlIO_stdstreams(pTHX)
956 {
957     if (!PL_perlio) {
958         PerlIO_allocate(aTHX);
959         PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
960         PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
961         PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
962     }
963 }
964
965 PerlIO *
966 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
967 {
968     PerlIOl *l = NULL;
969     Newc('L',l,tab->size,char,PerlIOl);
970     if (l && f) {
971         Zero(l, tab->size, char);
972         l->next = *f;
973         l->tab = tab;
974         *f = l;
975         PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
976                      (mode) ? mode : "(Null)", (void*)arg);
977         if ((*l->tab->Pushed) (aTHX_ f, mode, arg) != 0) {
978             PerlIO_pop(aTHX_ f);
979             return NULL;
980         }
981     }
982     return f;
983 }
984
985 IV
986 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
987 {
988     PerlIO_pop(aTHX_ f);
989     if (*f) {
990         PerlIO_flush(f);
991         PerlIO_pop(aTHX_ f);
992         return 0;
993     }
994     return -1;
995 }
996
997 IV
998 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
999 {
1000     /*
1001      * Remove the dummy layer
1002      */
1003     PerlIO_pop(aTHX_ f);
1004     /*
1005      * Pop back to bottom layer
1006      */
1007     if (f && *f) {
1008         PerlIO_flush(f);
1009         while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) {
1010             if (*PerlIONext(f)) {
1011                 PerlIO_pop(aTHX_ f);
1012             }
1013             else {
1014                 /*
1015                  * Nothing bellow - push unix on top then remove it
1016                  */
1017                 if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
1018                     PerlIO_pop(aTHX_ PerlIONext(f));
1019                 }
1020                 break;
1021             }
1022         }
1023         PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1024         return 0;
1025     }
1026     return -1;
1027 }
1028
1029 int
1030 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1031                     PerlIO_list_t *layers, IV n)
1032 {
1033     IV max = layers->cur;
1034     int code = 0;
1035     while (n < max) {
1036         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1037         if (tab) {
1038             if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1039                 code = -1;
1040                 break;
1041             }
1042         }
1043         n++;
1044     }
1045     return code;
1046 }
1047
1048 int
1049 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1050 {
1051     int code = 0;
1052     if (f && names) {
1053         PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
1054         code = PerlIO_parse_layers(aTHX_ layers, names);
1055         if (code == 0) {
1056             code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
1057         }
1058         PerlIO_list_free(aTHX_ layers);
1059     }
1060     return code;
1061 }
1062
1063
1064 /*--------------------------------------------------------------------------------------*/
1065 /*
1066  * Given the abstraction above the public API functions
1067  */
1068
1069 int
1070 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1071 {
1072     PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
1073                  (void*)f, PerlIOBase(f)->tab->name, iotype, mode,
1074                  (names) ? names : "(Null)");
1075     /* Can't flush if switching encodings. */
1076     if (!(names && memEQ(names, ":encoding(", 10))) {
1077         PerlIO_flush(f);
1078 #ifdef PERLIO_USING_CRLF
1079         if (!names && (mode & O_BINARY)) {
1080             PerlIO *top = f;
1081             while (*top) {
1082                 if (PerlIOBase(top)->tab == &PerlIO_crlf) {
1083                   PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
1084                   break;
1085                 }
1086                 top = PerlIONext(top);
1087                 PerlIO_flush(top);
1088             }
1089         }
1090 #endif
1091     }
1092     return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1093 }
1094
1095 int
1096 PerlIO__close(pTHX_ PerlIO *f)
1097 {
1098     if (f && *f)
1099         return (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1100     else {
1101         SETERRNO(EBADF, SS$_IVCHAN);
1102         return -1;
1103     }
1104 }
1105
1106 int
1107 Perl_PerlIO_close(pTHX_ PerlIO *f)
1108 {
1109     int code = -1;
1110     if (f && *f) {
1111         code = (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1112         while (*f) {
1113             PerlIO_pop(aTHX_ f);
1114         }
1115     }
1116     return code;
1117 }
1118
1119 int
1120 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1121 {
1122     if (f && *f)
1123         return (*PerlIOBase(f)->tab->Fileno) (aTHX_ f);
1124     else {
1125         SETERRNO(EBADF, SS$_IVCHAN);
1126         return -1;
1127     }
1128 }
1129
1130 static const char *
1131 PerlIO_context_layers(pTHX_ const char *mode)
1132 {
1133     const char *type = NULL;
1134     /*
1135      * Need to supply default layer info from open.pm
1136      */
1137     if (PL_curcop) {
1138         SV *layers = PL_curcop->cop_io;
1139         if (layers) {
1140             STRLEN len;
1141             type = SvPV(layers, len);
1142             if (type && mode[0] != 'r') {
1143                 /*
1144                  * Skip to write part
1145                  */
1146                 const char *s = strchr(type, 0);
1147                 if (s && (s - type) < len) {
1148                     type = s + 1;
1149                 }
1150             }
1151         }
1152     }
1153     return type;
1154 }
1155
1156 static PerlIO_funcs *
1157 PerlIO_layer_from_ref(pTHX_ SV *sv)
1158 {
1159     /*
1160      * For any scalar type load the handler which is bundled with perl
1161      */
1162     if (SvTYPE(sv) < SVt_PVAV)
1163         return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
1164
1165     /*
1166      * For other types allow if layer is known but don't try and load it
1167      */
1168     switch (SvTYPE(sv)) {
1169     case SVt_PVAV:
1170         return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1171     case SVt_PVHV:
1172         return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1173     case SVt_PVCV:
1174         return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1175     case SVt_PVGV:
1176         return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1177     }
1178     return NULL;
1179 }
1180
1181 PerlIO_list_t *
1182 PerlIO_resolve_layers(pTHX_ const char *layers,
1183                       const char *mode, int narg, SV **args)
1184 {
1185     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1186     int incdef = 1;
1187     if (!PL_perlio)
1188         PerlIO_stdstreams(aTHX);
1189     if (narg) {
1190         SV *arg = *args;
1191         /*
1192          * If it is a reference but not an object see if we have a handler
1193          * for it
1194          */
1195         if (SvROK(arg) && !sv_isobject(arg)) {
1196             PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1197             if (handler) {
1198                 def = PerlIO_list_alloc(aTHX);
1199                 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1200                 incdef = 0;
1201             }
1202             /*
1203              * Don't fail if handler cannot be found :Via(...) etc. may do
1204              * something sensible else we will just stringfy and open
1205              * resulting string.
1206              */
1207         }
1208     }
1209     if (!layers)
1210         layers = PerlIO_context_layers(aTHX_ mode);
1211     if (layers && *layers) {
1212         PerlIO_list_t *av;
1213         if (incdef) {
1214             IV i = def->cur;
1215             av = PerlIO_list_alloc(aTHX);
1216             for (i = 0; i < def->cur; i++) {
1217                 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1218                                  def->array[i].arg);
1219             }
1220         }
1221         else {
1222             av = def;
1223         }
1224         PerlIO_parse_layers(aTHX_ av, layers);
1225         return av;
1226     }
1227     else {
1228         if (incdef)
1229             def->refcnt++;
1230         return def;
1231     }
1232 }
1233
1234 PerlIO *
1235 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1236              int imode, int perm, PerlIO *f, int narg, SV **args)
1237 {
1238     if (!f && narg == 1 && *args == &PL_sv_undef) {
1239         if ((f = PerlIO_tmpfile())) {
1240             if (!layers)
1241                 layers = PerlIO_context_layers(aTHX_ mode);
1242             if (layers && *layers)
1243                 PerlIO_apply_layers(aTHX_ f, mode, layers);
1244         }
1245     }
1246     else {
1247         PerlIO_list_t *layera = NULL;
1248         IV n;
1249         PerlIO_funcs *tab = NULL;
1250         if (f && *f) {
1251             /*
1252              * This is "reopen" - it is not tested as perl does not use it
1253              * yet
1254              */
1255             PerlIOl *l = *f;
1256             layera = PerlIO_list_alloc(aTHX);
1257             while (l) {
1258                 SV *arg =
1259                     (l->tab->Getarg) ? (*l->tab->
1260                                         Getarg) (aTHX_ &l, NULL, 0) : &PL_sv_undef;
1261                 PerlIO_list_push(aTHX_ layera, l->tab, arg);
1262                 l = *PerlIONext(&l);
1263             }
1264         }
1265         else {
1266             layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1267         }
1268         /*
1269          * Start at "top" of layer stack
1270          */
1271         n = layera->cur - 1;
1272         while (n >= 0) {
1273             PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1274             if (t && t->Open) {
1275                 tab = t;
1276                 break;
1277             }
1278             n--;
1279         }
1280         if (tab) {
1281             /*
1282              * Found that layer 'n' can do opens - call it
1283              */
1284             if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1285                 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1286             }
1287             PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1288                          tab->name, layers, mode, fd, imode, perm,
1289                          (void*)f, narg, (void*)args);
1290             f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1291                               f, narg, args);
1292             if (f) {
1293                 if (n + 1 < layera->cur) {
1294                     /*
1295                      * More layers above the one that we used to open -
1296                      * apply them now
1297                      */
1298                     if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1)
1299                         != 0) {
1300                         f = NULL;
1301                     }
1302                 }
1303             }
1304         }
1305         PerlIO_list_free(aTHX_ layera);
1306     }
1307     return f;
1308 }
1309
1310
1311 SSize_t
1312 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1313 {
1314     if (f && *f)
1315         return (*PerlIOBase(f)->tab->Read) (aTHX_ f, vbuf, count);
1316     else {
1317         SETERRNO(EBADF, SS$_IVCHAN);
1318         return -1;
1319     }
1320 }
1321
1322 SSize_t
1323 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1324 {
1325     if (f && *f)
1326         return (*PerlIOBase(f)->tab->Unread) (aTHX_ f, vbuf, count);
1327     else {
1328         SETERRNO(EBADF, SS$_IVCHAN);
1329         return -1;
1330     }
1331 }
1332
1333 SSize_t
1334 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1335 {
1336     if (f && *f)
1337         return (*PerlIOBase(f)->tab->Write) (aTHX_ f, vbuf, count);
1338     else {
1339         SETERRNO(EBADF, SS$_IVCHAN);
1340         return -1;
1341     }
1342 }
1343
1344 int
1345 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1346 {
1347     if (f && *f)
1348         return (*PerlIOBase(f)->tab->Seek) (aTHX_ f, offset, whence);
1349     else {
1350         SETERRNO(EBADF, SS$_IVCHAN);
1351         return -1;
1352     }
1353 }
1354
1355 Off_t
1356 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1357 {
1358     if (f && *f)
1359         return (*PerlIOBase(f)->tab->Tell) (aTHX_ f);
1360     else {
1361         SETERRNO(EBADF, SS$_IVCHAN);
1362         return -1;
1363     }
1364 }
1365
1366 int
1367 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1368 {
1369     if (f) {
1370         if (*f) {
1371             PerlIO_funcs *tab = PerlIOBase(f)->tab;
1372             if (tab && tab->Flush) {
1373                 return (*tab->Flush) (aTHX_ f);
1374             }
1375             else {
1376                 PerlIO_debug("Cannot flush f=%p :%s\n", (void*)f, tab->name);
1377                 SETERRNO(EBADF, SS$_IVCHAN);
1378                 return -1;
1379             }
1380         }
1381         else {
1382             PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1383             SETERRNO(EBADF, SS$_IVCHAN);
1384             return -1;
1385         }
1386     }
1387     else {
1388         /*
1389          * Is it good API design to do flush-all on NULL, a potentially
1390          * errorneous input? Maybe some magical value (PerlIO*
1391          * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1392          * things on fflush(NULL), but should we be bound by their design
1393          * decisions? --jhi
1394          */
1395         PerlIO **table = &PL_perlio;
1396         int code = 0;
1397         while ((f = *table)) {
1398             int i;
1399             table = (PerlIO **) (f++);
1400             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1401                 if (*f && PerlIO_flush(f) != 0)
1402                     code = -1;
1403                 f++;
1404             }
1405         }
1406         return code;
1407     }
1408 }
1409
1410 void
1411 PerlIOBase_flush_linebuf(pTHX)
1412 {
1413     PerlIO **table = &PL_perlio;
1414     PerlIO *f;
1415     while ((f = *table)) {
1416         int i;
1417         table = (PerlIO **) (f++);
1418         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1419             if (*f
1420                 && (PerlIOBase(f)->
1421                     flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1422                 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1423                 PerlIO_flush(f);
1424             f++;
1425         }
1426     }
1427 }
1428
1429 int
1430 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1431 {
1432     if (f && *f)
1433         return (*PerlIOBase(f)->tab->Fill) (aTHX_ f);
1434     else {
1435         SETERRNO(EBADF, SS$_IVCHAN);
1436         return -1;
1437     }
1438 }
1439
1440 int
1441 PerlIO_isutf8(PerlIO *f)
1442 {
1443     if (f && *f)
1444         return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1445     else {
1446         SETERRNO(EBADF, SS$_IVCHAN);
1447         return -1;
1448     }
1449 }
1450
1451 int
1452 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1453 {
1454     if (f && *f)
1455         return (*PerlIOBase(f)->tab->Eof) (aTHX_ f);
1456     else {
1457         SETERRNO(EBADF, SS$_IVCHAN);
1458         return -1;
1459     }
1460 }
1461
1462 int
1463 Perl_PerlIO_error(pTHX_ PerlIO *f)
1464 {
1465     if (f && *f)
1466         return (*PerlIOBase(f)->tab->Error) (aTHX_ f);
1467     else {
1468         SETERRNO(EBADF, SS$_IVCHAN);
1469         return -1;
1470     }
1471 }
1472
1473 void
1474 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1475 {
1476     if (f && *f)
1477         (*PerlIOBase(f)->tab->Clearerr) (aTHX_ f);
1478     else
1479         SETERRNO(EBADF, SS$_IVCHAN);
1480 }
1481
1482 void
1483 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1484 {
1485     if (f && *f)
1486         (*PerlIOBase(f)->tab->Setlinebuf) (aTHX_ f);
1487     else
1488         SETERRNO(EBADF, SS$_IVCHAN);
1489 }
1490
1491 int
1492 PerlIO_has_base(PerlIO *f)
1493 {
1494     if (f && *f) {
1495         return (PerlIOBase(f)->tab->Get_base != NULL);
1496     }
1497     return 0;
1498 }
1499
1500 int
1501 PerlIO_fast_gets(PerlIO *f)
1502 {
1503     if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1504         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1505         return (tab->Set_ptrcnt != NULL);
1506     }
1507     return 0;
1508 }
1509
1510 int
1511 PerlIO_has_cntptr(PerlIO *f)
1512 {
1513     if (f && *f) {
1514         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1515         return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1516     }
1517     return 0;
1518 }
1519
1520 int
1521 PerlIO_canset_cnt(PerlIO *f)
1522 {
1523     if (f && *f) {
1524         PerlIOl *l = PerlIOBase(f);
1525         return (l->tab->Set_ptrcnt != NULL);
1526     }
1527     return 0;
1528 }
1529
1530 STDCHAR *
1531 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1532 {
1533     if (f && *f)
1534         return (*PerlIOBase(f)->tab->Get_base) (aTHX_ f);
1535     return NULL;
1536 }
1537
1538 int
1539 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1540 {
1541     if (f && *f)
1542         return (*PerlIOBase(f)->tab->Get_bufsiz) (aTHX_ f);
1543     return 0;
1544 }
1545
1546 STDCHAR *
1547 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1548 {
1549     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1550     if (tab->Get_ptr == NULL)
1551         return NULL;
1552     return (*tab->Get_ptr) (aTHX_ f);
1553 }
1554
1555 int
1556 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1557 {
1558     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1559     if (tab->Get_cnt == NULL)
1560         return 0;
1561     return (*tab->Get_cnt) (aTHX_ f);
1562 }
1563
1564 void
1565 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1566 {
1567     (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, NULL, cnt);
1568 }
1569
1570 void
1571 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1572 {
1573     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1574     if (tab->Set_ptrcnt == NULL) {
1575         Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1576     }
1577     (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, ptr, cnt);
1578 }
1579
1580 /*--------------------------------------------------------------------------------------*/
1581 /*
1582  * utf8 and raw dummy layers
1583  */
1584
1585 IV
1586 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1587 {
1588     if (PerlIONext(f)) {
1589         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1590         PerlIO_pop(aTHX_ f);
1591         if (tab->kind & PERLIO_K_UTF8)
1592             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1593         else
1594             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1595         return 0;
1596     }
1597     return -1;
1598 }
1599
1600 PerlIO_funcs PerlIO_utf8 = {
1601     "utf8",
1602     sizeof(PerlIOl),
1603     PERLIO_K_DUMMY | PERLIO_F_UTF8,
1604     PerlIOUtf8_pushed,
1605     NULL,
1606     NULL,
1607     NULL,
1608     NULL,
1609     NULL,
1610     NULL,
1611     NULL,
1612     NULL,
1613     NULL,
1614     NULL,
1615     NULL,                       /* flush */
1616     NULL,                       /* fill */
1617     NULL,
1618     NULL,
1619     NULL,
1620     NULL,
1621     NULL,                       /* get_base */
1622     NULL,                       /* get_bufsiz */
1623     NULL,                       /* get_ptr */
1624     NULL,                       /* get_cnt */
1625     NULL,                       /* set_ptrcnt */
1626 };
1627
1628 PerlIO_funcs PerlIO_byte = {
1629     "bytes",
1630     sizeof(PerlIOl),
1631     PERLIO_K_DUMMY,
1632     PerlIOUtf8_pushed,
1633     NULL,
1634     NULL,
1635     NULL,
1636     NULL,
1637     NULL,
1638     NULL,
1639     NULL,
1640     NULL,
1641     NULL,
1642     NULL,
1643     NULL,                       /* flush */
1644     NULL,                       /* fill */
1645     NULL,
1646     NULL,
1647     NULL,
1648     NULL,
1649     NULL,                       /* get_base */
1650     NULL,                       /* get_bufsiz */
1651     NULL,                       /* get_ptr */
1652     NULL,                       /* get_cnt */
1653     NULL,                       /* set_ptrcnt */
1654 };
1655
1656 PerlIO *
1657 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1658                IV n, const char *mode, int fd, int imode, int perm,
1659                PerlIO *old, int narg, SV **args)
1660 {
1661     PerlIO_funcs *tab = PerlIO_default_btm();
1662     return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1663                          old, narg, args);
1664 }
1665
1666 PerlIO_funcs PerlIO_raw = {
1667     "raw",
1668     sizeof(PerlIOl),
1669     PERLIO_K_DUMMY,
1670     PerlIORaw_pushed,
1671     PerlIOBase_popped,
1672     PerlIORaw_open,
1673     NULL,
1674     NULL,
1675     NULL,
1676     NULL,
1677     NULL,
1678     NULL,
1679     NULL,
1680     NULL,
1681     NULL,                       /* flush */
1682     NULL,                       /* fill */
1683     NULL,
1684     NULL,
1685     NULL,
1686     NULL,
1687     NULL,                       /* get_base */
1688     NULL,                       /* get_bufsiz */
1689     NULL,                       /* get_ptr */
1690     NULL,                       /* get_cnt */
1691     NULL,                       /* set_ptrcnt */
1692 };
1693 /*--------------------------------------------------------------------------------------*/
1694 /*--------------------------------------------------------------------------------------*/
1695 /*
1696  * "Methods" of the "base class"
1697  */
1698
1699 IV
1700 PerlIOBase_fileno(pTHX_ PerlIO *f)
1701 {
1702     return PerlIO_fileno(PerlIONext(f));
1703 }
1704
1705 char *
1706 PerlIO_modestr(PerlIO *f, char *buf)
1707 {
1708     char *s = buf;
1709     IV flags = PerlIOBase(f)->flags;
1710     if (flags & PERLIO_F_APPEND) {
1711         *s++ = 'a';
1712         if (flags & PERLIO_F_CANREAD) {
1713             *s++ = '+';
1714         }
1715     }
1716     else if (flags & PERLIO_F_CANREAD) {
1717         *s++ = 'r';
1718         if (flags & PERLIO_F_CANWRITE)
1719             *s++ = '+';
1720     }
1721     else if (flags & PERLIO_F_CANWRITE) {
1722         *s++ = 'w';
1723         if (flags & PERLIO_F_CANREAD) {
1724             *s++ = '+';
1725         }
1726     }
1727 #ifdef PERLIO_USING_CRLF
1728     if (!(flags & PERLIO_F_CRLF))
1729         *s++ = 'b';
1730 #endif
1731     *s = '\0';
1732     return buf;
1733 }
1734
1735 IV
1736 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1737 {
1738     PerlIOl *l = PerlIOBase(f);
1739 #if 0
1740     const char *omode = mode;
1741     char temp[8];
1742 #endif
1743     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1744     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1745                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1746     if (tab->Set_ptrcnt != NULL)
1747         l->flags |= PERLIO_F_FASTGETS;
1748     if (mode) {
1749         if (*mode == '#' || *mode == 'I')
1750             mode++;
1751         switch (*mode++) {
1752         case 'r':
1753             l->flags |= PERLIO_F_CANREAD;
1754             break;
1755         case 'a':
1756             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1757             break;
1758         case 'w':
1759             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1760             break;
1761         default:
1762             SETERRNO(EINVAL, LIB$_INVARG);
1763             return -1;
1764         }
1765         while (*mode) {
1766             switch (*mode++) {
1767             case '+':
1768                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1769                 break;
1770             case 'b':
1771                 l->flags &= ~PERLIO_F_CRLF;
1772                 break;
1773             case 't':
1774                 l->flags |= PERLIO_F_CRLF;
1775                 break;
1776             default:
1777                 SETERRNO(EINVAL, LIB$_INVARG);
1778                 return -1;
1779             }
1780         }
1781     }
1782     else {
1783         if (l->next) {
1784             l->flags |= l->next->flags &
1785                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
1786                  PERLIO_F_APPEND);
1787         }
1788     }
1789 #if 0
1790     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
1791                  f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
1792                  l->flags, PerlIO_modestr(f, temp));
1793 #endif
1794     return 0;
1795 }
1796
1797 IV
1798 PerlIOBase_popped(pTHX_ PerlIO *f)
1799 {
1800     return 0;
1801 }
1802
1803 SSize_t
1804 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1805 {
1806     /*
1807      * Save the position as current head considers it
1808      */
1809     Off_t old = PerlIO_tell(f);
1810     SSize_t done;
1811     PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
1812     PerlIOSelf(f, PerlIOBuf)->posn = old;
1813     done = PerlIOBuf_unread(aTHX_ f, vbuf, count);
1814     return done;
1815 }
1816
1817 SSize_t
1818 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1819 {
1820     STDCHAR *buf = (STDCHAR *) vbuf;
1821     if (f) {
1822         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1823             return 0;
1824         while (count > 0) {
1825             SSize_t avail = PerlIO_get_cnt(f);
1826             SSize_t take = 0;
1827             if (avail > 0)
1828                 take = (count < avail) ? count : avail;
1829             if (take > 0) {
1830                 STDCHAR *ptr = PerlIO_get_ptr(f);
1831                 Copy(ptr, buf, take, STDCHAR);
1832                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
1833                 count -= take;
1834                 buf += take;
1835             }
1836             if (count > 0 && avail <= 0) {
1837                 if (PerlIO_fill(f) != 0)
1838                     break;
1839             }
1840         }
1841         return (buf - (STDCHAR *) vbuf);
1842     }
1843     return 0;
1844 }
1845
1846 IV
1847 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
1848 {
1849     return 0;
1850 }
1851
1852 IV
1853 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
1854 {
1855     return -1;
1856 }
1857
1858 IV
1859 PerlIOBase_close(pTHX_ PerlIO *f)
1860 {
1861     IV code = 0;
1862     PerlIO *n = PerlIONext(f);
1863     if (PerlIO_flush(f) != 0)
1864         code = -1;
1865     if (n && *n && (*PerlIOBase(n)->tab->Close)(aTHX_ n) != 0)
1866         code = -1;
1867     PerlIOBase(f)->flags &=
1868         ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
1869     return code;
1870 }
1871
1872 IV
1873 PerlIOBase_eof(pTHX_ PerlIO *f)
1874 {
1875     if (f && *f) {
1876         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1877     }
1878     return 1;
1879 }
1880
1881 IV
1882 PerlIOBase_error(pTHX_ PerlIO *f)
1883 {
1884     if (f && *f) {
1885         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1886     }
1887     return 1;
1888 }
1889
1890 void
1891 PerlIOBase_clearerr(pTHX_ PerlIO *f)
1892 {
1893     if (f && *f) {
1894         PerlIO *n = PerlIONext(f);
1895         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
1896         if (n)
1897             PerlIO_clearerr(n);
1898     }
1899 }
1900
1901 void
1902 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
1903 {
1904     if (f) {
1905         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1906     }
1907 }
1908
1909 SV *
1910 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
1911 {
1912     if (!arg)
1913         return Nullsv;
1914 #ifdef sv_dup
1915     if (param) {
1916         return sv_dup(arg, param);
1917     }
1918     else {
1919         return newSVsv(arg);
1920     }
1921 #else
1922     return newSVsv(arg);
1923 #endif
1924 }
1925
1926 PerlIO *
1927 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1928 {
1929     PerlIO *nexto = PerlIONext(o);
1930     if (*nexto) {
1931         PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
1932         f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
1933     }
1934     if (f) {
1935         PerlIO_funcs *self = PerlIOBase(o)->tab;
1936         SV *arg = Nullsv;
1937         char buf[8];
1938         PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
1939                      self->name, (void*)f, (void*)o, (void*)param);
1940         if (self->Getarg) {
1941             arg = (*self->Getarg)(aTHX_ o,param,flags);
1942         }
1943         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
1944         if (arg) {
1945             SvREFCNT_dec(arg);
1946         }
1947     }
1948     return f;
1949 }
1950
1951 #define PERLIO_MAX_REFCOUNTABLE_FD 2048
1952 #ifdef USE_THREADS
1953 perl_mutex PerlIO_mutex;
1954 #endif
1955 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
1956
1957 void
1958 PerlIO_init(pTHX)
1959 {
1960  /* Place holder for stdstreams call ??? */
1961 #ifdef USE_THREADS
1962  MUTEX_INIT(&PerlIO_mutex);
1963 #endif
1964 }
1965
1966 void
1967 PerlIOUnix_refcnt_inc(int fd)
1968 {
1969     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
1970 #ifdef USE_THREADS
1971         MUTEX_LOCK(&PerlIO_mutex);
1972 #endif
1973         PerlIO_fd_refcnt[fd]++;
1974         PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
1975 #ifdef USE_THREADS
1976         MUTEX_UNLOCK(&PerlIO_mutex);
1977 #endif
1978     }
1979 }
1980
1981 int
1982 PerlIOUnix_refcnt_dec(int fd)
1983 {
1984     int cnt = 0;
1985     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
1986 #ifdef USE_THREADS
1987         MUTEX_LOCK(&PerlIO_mutex);
1988 #endif
1989         cnt = --PerlIO_fd_refcnt[fd];
1990         PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
1991 #ifdef USE_THREADS
1992         MUTEX_UNLOCK(&PerlIO_mutex);
1993 #endif
1994     }
1995     return cnt;
1996 }
1997
1998 void
1999 PerlIO_cleanup(pTHX)
2000 {
2001     int i;
2002 #ifdef USE_ITHREADS
2003     PerlIO_debug("Cleanup %p\n",aTHX);
2004 #endif
2005     /* Raise STDIN..STDERR refcount so we don't close them */
2006     for (i=0; i < 3; i++)
2007         PerlIOUnix_refcnt_inc(i);
2008     PerlIO_cleantable(aTHX_ &PL_perlio);
2009     /* Restore STDIN..STDERR refcount */
2010     for (i=0; i < 3; i++)
2011         PerlIOUnix_refcnt_dec(i);
2012 }
2013
2014
2015
2016 /*--------------------------------------------------------------------------------------*/
2017 /*
2018  * Bottom-most level for UNIX-like case
2019  */
2020
2021 typedef struct {
2022     struct _PerlIO base;        /* The generic part */
2023     int fd;                     /* UNIX like file descriptor */
2024     int oflags;                 /* open/fcntl flags */
2025 } PerlIOUnix;
2026
2027 int
2028 PerlIOUnix_oflags(const char *mode)
2029 {
2030     int oflags = -1;
2031     if (*mode == 'I' || *mode == '#')
2032         mode++;
2033     switch (*mode) {
2034     case 'r':
2035         oflags = O_RDONLY;
2036         if (*++mode == '+') {
2037             oflags = O_RDWR;
2038             mode++;
2039         }
2040         break;
2041
2042     case 'w':
2043         oflags = O_CREAT | O_TRUNC;
2044         if (*++mode == '+') {
2045             oflags |= O_RDWR;
2046             mode++;
2047         }
2048         else
2049             oflags |= O_WRONLY;
2050         break;
2051
2052     case 'a':
2053         oflags = O_CREAT | O_APPEND;
2054         if (*++mode == '+') {
2055             oflags |= O_RDWR;
2056             mode++;
2057         }
2058         else
2059             oflags |= O_WRONLY;
2060         break;
2061     }
2062     if (*mode == 'b') {
2063         oflags |= O_BINARY;
2064         oflags &= ~O_TEXT;
2065         mode++;
2066     }
2067     else if (*mode == 't') {
2068         oflags |= O_TEXT;
2069         oflags &= ~O_BINARY;
2070         mode++;
2071     }
2072     /*
2073      * Always open in binary mode
2074      */
2075     oflags |= O_BINARY;
2076     if (*mode || oflags == -1) {
2077         SETERRNO(EINVAL, LIB$_INVARG);
2078         oflags = -1;
2079     }
2080     return oflags;
2081 }
2082
2083 IV
2084 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2085 {
2086     return PerlIOSelf(f, PerlIOUnix)->fd;
2087 }
2088
2089 IV
2090 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2091 {
2092     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
2093     PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2094     if (*PerlIONext(f)) {
2095         s->fd = PerlIO_fileno(PerlIONext(f));
2096         /*
2097          * XXX could (or should) we retrieve the oflags from the open file
2098          * handle rather than believing the "mode" we are passed in? XXX
2099          * Should the value on NULL mode be 0 or -1?
2100          */
2101         s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
2102     }
2103     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2104     return code;
2105 }
2106
2107 PerlIO *
2108 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2109                 IV n, const char *mode, int fd, int imode,
2110                 int perm, PerlIO *f, int narg, SV **args)
2111 {
2112     if (f) {
2113         if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2114             (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2115     }
2116     if (narg > 0) {
2117         char *path = SvPV_nolen(*args);
2118         if (*mode == '#')
2119             mode++;
2120         else {
2121             imode = PerlIOUnix_oflags(mode);
2122             perm = 0666;
2123         }
2124         if (imode != -1) {
2125             fd = PerlLIO_open3(path, imode, perm);
2126         }
2127     }
2128     if (fd >= 0) {
2129         PerlIOUnix *s;
2130         if (*mode == 'I')
2131             mode++;
2132         if (!f) {
2133             f = PerlIO_allocate(aTHX);
2134             s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
2135                            PerlIOUnix);
2136         }
2137         else
2138             s = PerlIOSelf(f, PerlIOUnix);
2139         s->fd = fd;
2140         s->oflags = imode;
2141         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2142         PerlIOUnix_refcnt_inc(fd);
2143         return f;
2144     }
2145     else {
2146         if (f) {
2147             /*
2148              * FIXME: pop layers ???
2149              */
2150         }
2151         return NULL;
2152     }
2153 }
2154
2155 PerlIO *
2156 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2157 {
2158     PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2159     int fd = os->fd;
2160     if (flags & PERLIO_DUP_FD) {
2161         fd = PerlLIO_dup(fd);
2162     }
2163     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2164         f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2165         if (f) {
2166             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2167             PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2168             s->fd = fd;
2169             PerlIOUnix_refcnt_inc(fd);
2170             return f;
2171         }
2172     }
2173     return NULL;
2174 }
2175
2176
2177 SSize_t
2178 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2179 {
2180     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2181     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2182         return 0;
2183     while (1) {
2184         SSize_t len = PerlLIO_read(fd, vbuf, count);
2185         if (len >= 0 || errno != EINTR) {
2186             if (len < 0)
2187                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2188             else if (len == 0 && count != 0)
2189                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2190             return len;
2191         }
2192         PERL_ASYNC_CHECK();
2193     }
2194 }
2195
2196 SSize_t
2197 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2198 {
2199     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2200     while (1) {
2201         SSize_t len = PerlLIO_write(fd, vbuf, count);
2202         if (len >= 0 || errno != EINTR) {
2203             if (len < 0)
2204                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2205             return len;
2206         }
2207         PERL_ASYNC_CHECK();
2208     }
2209 }
2210
2211 IV
2212 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2213 {
2214     Off_t new =
2215         PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence);
2216     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2217     return (new == (Off_t) - 1) ? -1 : 0;
2218 }
2219
2220 Off_t
2221 PerlIOUnix_tell(pTHX_ PerlIO *f)
2222 {
2223     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2224 }
2225
2226
2227 IV
2228 PerlIOUnix_close(pTHX_ PerlIO *f)
2229 {
2230     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2231     int code = 0;
2232     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2233         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2234             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2235             return 0;
2236         }
2237     }
2238     else {
2239         SETERRNO(EBADF,SS$_IVCHAN);
2240         return -1;
2241     }
2242     while (PerlLIO_close(fd) != 0) {
2243         if (errno != EINTR) {
2244             code = -1;
2245             break;
2246         }
2247         PERL_ASYNC_CHECK();
2248     }
2249     if (code == 0) {
2250         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2251     }
2252     return code;
2253 }
2254
2255 PerlIO_funcs PerlIO_unix = {
2256     "unix",
2257     sizeof(PerlIOUnix),
2258     PERLIO_K_RAW,
2259     PerlIOUnix_pushed,
2260     PerlIOBase_noop_ok,
2261     PerlIOUnix_open,
2262     NULL,
2263     PerlIOUnix_fileno,
2264     PerlIOUnix_dup,
2265     PerlIOUnix_read,
2266     PerlIOBase_unread,
2267     PerlIOUnix_write,
2268     PerlIOUnix_seek,
2269     PerlIOUnix_tell,
2270     PerlIOUnix_close,
2271     PerlIOBase_noop_ok,         /* flush */
2272     PerlIOBase_noop_fail,       /* fill */
2273     PerlIOBase_eof,
2274     PerlIOBase_error,
2275     PerlIOBase_clearerr,
2276     PerlIOBase_setlinebuf,
2277     NULL,                       /* get_base */
2278     NULL,                       /* get_bufsiz */
2279     NULL,                       /* get_ptr */
2280     NULL,                       /* get_cnt */
2281     NULL,                       /* set_ptrcnt */
2282 };
2283
2284 /*--------------------------------------------------------------------------------------*/
2285 /*
2286  * stdio as a layer
2287  */
2288
2289 typedef struct {
2290     struct _PerlIO base;
2291     FILE *stdio;                /* The stream */
2292 } PerlIOStdio;
2293
2294 IV
2295 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2296 {
2297     return PerlSIO_fileno(PerlIOSelf(f, PerlIOStdio)->stdio);
2298 }
2299
2300 char *
2301 PerlIOStdio_mode(const char *mode, char *tmode)
2302 {
2303     char *ret = tmode;
2304     while (*mode) {
2305         *tmode++ = *mode++;
2306     }
2307 #ifdef PERLIO_USING_CRLF
2308     *tmode++ = 'b';
2309 #endif
2310     *tmode = '\0';
2311     return ret;
2312 }
2313
2314 /*
2315  * This isn't used yet ...
2316  */
2317 IV
2318 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2319 {
2320     if (*PerlIONext(f)) {
2321         PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2322         char tmode[8];
2323         FILE *stdio =
2324             PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)), mode =
2325                            PerlIOStdio_mode(mode, tmode));
2326         if (stdio)
2327             s->stdio = stdio;
2328         else
2329             return -1;
2330     }
2331     return PerlIOBase_pushed(aTHX_ f, mode, arg);
2332 }
2333
2334 PerlIO *
2335 PerlIO_importFILE(FILE *stdio, int fl)
2336 {
2337     dTHX;
2338     PerlIO *f = NULL;
2339     if (stdio) {
2340         PerlIOStdio *s =
2341             PerlIOSelf(PerlIO_push
2342                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
2343                         "r+", Nullsv), PerlIOStdio);
2344         s->stdio = stdio;
2345     }
2346     return f;
2347 }
2348
2349 PerlIO *
2350 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2351                  IV n, const char *mode, int fd, int imode,
2352                  int perm, PerlIO *f, int narg, SV **args)
2353 {
2354     char tmode[8];
2355     if (f) {
2356         char *path = SvPV_nolen(*args);
2357         PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2358         FILE *stdio;
2359         PerlIOUnix_refcnt_dec(fileno(s->stdio));
2360         stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2361                             s->stdio);
2362         if (!s->stdio)
2363             return NULL;
2364         s->stdio = stdio;
2365         PerlIOUnix_refcnt_inc(fileno(s->stdio));
2366         return f;
2367     }
2368     else {
2369         if (narg > 0) {
2370             char *path = SvPV_nolen(*args);
2371             if (*mode == '#') {
2372                 mode++;
2373                 fd = PerlLIO_open3(path, imode, perm);
2374             }
2375             else {
2376                 FILE *stdio = PerlSIO_fopen(path, mode);
2377                 if (stdio) {
2378                     PerlIOStdio *s =
2379                         PerlIOSelf(PerlIO_push
2380                                    (aTHX_(f = PerlIO_allocate(aTHX)), self,
2381                                     (mode = PerlIOStdio_mode(mode, tmode)),
2382                                     PerlIOArg),
2383                                    PerlIOStdio);
2384                     s->stdio = stdio;
2385                     PerlIOUnix_refcnt_inc(fileno(s->stdio));
2386                 }
2387                 return f;
2388             }
2389         }
2390         if (fd >= 0) {
2391             FILE *stdio = NULL;
2392             int init = 0;
2393             if (*mode == 'I') {
2394                 init = 1;
2395                 mode++;
2396             }
2397             if (init) {
2398                 switch (fd) {
2399                 case 0:
2400                     stdio = PerlSIO_stdin;
2401                     break;
2402                 case 1:
2403                     stdio = PerlSIO_stdout;
2404                     break;
2405                 case 2:
2406                     stdio = PerlSIO_stderr;
2407                     break;
2408                 }
2409             }
2410             else {
2411                 stdio = PerlSIO_fdopen(fd, mode =
2412                                        PerlIOStdio_mode(mode, tmode));
2413             }
2414             if (stdio) {
2415                 PerlIOStdio *s =
2416                     PerlIOSelf(PerlIO_push
2417                                (aTHX_(f = PerlIO_allocate(aTHX)), self,
2418                                 mode, PerlIOArg), PerlIOStdio);
2419                 s->stdio = stdio;
2420                 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2421                 return f;
2422             }
2423         }
2424     }
2425     return NULL;
2426 }
2427
2428 PerlIO *
2429 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2430 {
2431     /* This assumes no layers underneath - which is what
2432        happens, but is not how I remember it. NI-S 2001/10/16
2433      */
2434     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2435         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2436         if (flags & PERLIO_DUP_FD) {
2437             int fd = PerlLIO_dup(fileno(stdio));
2438             if (fd >= 0) {
2439                 char mode[8];
2440                 stdio = fdopen(fd, PerlIO_modestr(o,mode));
2441             }
2442             else {
2443                 /* FIXME: To avoid messy error recovery if dup fails
2444                    re-use the existing stdio as though flag was not set
2445                  */
2446             }
2447         }
2448         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2449         PerlIOUnix_refcnt_inc(fileno(stdio));
2450     }
2451     return f;
2452 }
2453
2454 IV
2455 PerlIOStdio_close(pTHX_ PerlIO *f)
2456 {
2457 #ifdef SOCKS5_VERSION_NAME
2458     int optval;
2459     Sock_size_t optlen = sizeof(int);
2460 #endif
2461     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2462     if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2463         /* Do not close it but do flush any buffers */
2464         PerlIO_flush(f);
2465         return 0;
2466     }
2467     return (
2468 #ifdef SOCKS5_VERSION_NAME
2469                (getsockopt
2470                 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2471                  &optlen) <
2472                 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2473 #else
2474                PerlSIO_fclose(stdio)
2475 #endif
2476         );
2477
2478 }
2479
2480
2481
2482 SSize_t
2483 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2484 {
2485     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2486     SSize_t got = 0;
2487     if (count == 1) {
2488         STDCHAR *buf = (STDCHAR *) vbuf;
2489         /*
2490          * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2491          * stdio does not do that for fread()
2492          */
2493         int ch = PerlSIO_fgetc(s);
2494         if (ch != EOF) {
2495             *buf = ch;
2496             got = 1;
2497         }
2498     }
2499     else
2500         got = PerlSIO_fread(vbuf, 1, count, s);
2501     return got;
2502 }
2503
2504 SSize_t
2505 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2506 {
2507     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2508     STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
2509     SSize_t unread = 0;
2510     while (count > 0) {
2511         int ch = *buf-- & 0xff;
2512         if (PerlSIO_ungetc(ch, s) != ch)
2513             break;
2514         unread++;
2515         count--;
2516     }
2517     return unread;
2518 }
2519
2520 SSize_t
2521 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2522 {
2523     return PerlSIO_fwrite(vbuf, 1, count,
2524                           PerlIOSelf(f, PerlIOStdio)->stdio);
2525 }
2526
2527 IV
2528 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2529 {
2530     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2531     return PerlSIO_fseek(stdio, offset, whence);
2532 }
2533
2534 Off_t
2535 PerlIOStdio_tell(pTHX_ PerlIO *f)
2536 {
2537     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2538     return PerlSIO_ftell(stdio);
2539 }
2540
2541 IV
2542 PerlIOStdio_flush(pTHX_ PerlIO *f)
2543 {
2544     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2545     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2546         return PerlSIO_fflush(stdio);
2547     }
2548     else {
2549 #if 0
2550         /*
2551          * FIXME: This discards ungetc() and pre-read stuff which is not
2552          * right if this is just a "sync" from a layer above Suspect right
2553          * design is to do _this_ but not have layer above flush this
2554          * layer read-to-read
2555          */
2556         /*
2557          * Not writeable - sync by attempting a seek
2558          */
2559         int err = errno;
2560         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2561             errno = err;
2562 #endif
2563     }
2564     return 0;
2565 }
2566
2567 IV
2568 PerlIOStdio_fill(pTHX_ PerlIO *f)
2569 {
2570     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2571     int c;
2572     /*
2573      * fflush()ing read-only streams can cause trouble on some stdio-s
2574      */
2575     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2576         if (PerlSIO_fflush(stdio) != 0)
2577             return EOF;
2578     }
2579     c = PerlSIO_fgetc(stdio);
2580     if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
2581         return EOF;
2582     return 0;
2583 }
2584
2585 IV
2586 PerlIOStdio_eof(pTHX_ PerlIO *f)
2587 {
2588     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2589 }
2590
2591 IV
2592 PerlIOStdio_error(pTHX_ PerlIO *f)
2593 {
2594     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2595 }
2596
2597 void
2598 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
2599 {
2600     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2601 }
2602
2603 void
2604 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
2605 {
2606 #ifdef HAS_SETLINEBUF
2607     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2608 #else
2609     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2610 #endif
2611 }
2612
2613 #ifdef FILE_base
2614 STDCHAR *
2615 PerlIOStdio_get_base(pTHX_ PerlIO *f)
2616 {
2617     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2618     return (STDCHAR*)PerlSIO_get_base(stdio);
2619 }
2620
2621 Size_t
2622 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
2623 {
2624     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2625     return PerlSIO_get_bufsiz(stdio);
2626 }
2627 #endif
2628
2629 #ifdef USE_STDIO_PTR
2630 STDCHAR *
2631 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
2632 {
2633     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2634     return (STDCHAR*)PerlSIO_get_ptr(stdio);
2635 }
2636
2637 SSize_t
2638 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
2639 {
2640     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2641     return PerlSIO_get_cnt(stdio);
2642 }
2643
2644 void
2645 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2646 {
2647     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2648     if (ptr != NULL) {
2649 #ifdef STDIO_PTR_LVALUE
2650         PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
2651 #ifdef STDIO_PTR_LVAL_SETS_CNT
2652         if (PerlSIO_get_cnt(stdio) != (cnt)) {
2653             assert(PerlSIO_get_cnt(stdio) == (cnt));
2654         }
2655 #endif
2656 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2657         /*
2658          * Setting ptr _does_ change cnt - we are done
2659          */
2660         return;
2661 #endif
2662 #else                           /* STDIO_PTR_LVALUE */
2663         PerlProc_abort();
2664 #endif                          /* STDIO_PTR_LVALUE */
2665     }
2666     /*
2667      * Now (or only) set cnt
2668      */
2669 #ifdef STDIO_CNT_LVALUE
2670     PerlSIO_set_cnt(stdio, cnt);
2671 #else                           /* STDIO_CNT_LVALUE */
2672 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2673     PerlSIO_set_ptr(stdio,
2674                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2675                                               cnt));
2676 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
2677     PerlProc_abort();
2678 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
2679 #endif                          /* STDIO_CNT_LVALUE */
2680 }
2681
2682 #endif
2683
2684 PerlIO_funcs PerlIO_stdio = {
2685     "stdio",
2686     sizeof(PerlIOStdio),
2687     PERLIO_K_BUFFERED,
2688     PerlIOBase_pushed,
2689     PerlIOBase_noop_ok,
2690     PerlIOStdio_open,
2691     NULL,
2692     PerlIOStdio_fileno,
2693     PerlIOStdio_dup,
2694     PerlIOStdio_read,
2695     PerlIOStdio_unread,
2696     PerlIOStdio_write,
2697     PerlIOStdio_seek,
2698     PerlIOStdio_tell,
2699     PerlIOStdio_close,
2700     PerlIOStdio_flush,
2701     PerlIOStdio_fill,
2702     PerlIOStdio_eof,
2703     PerlIOStdio_error,
2704     PerlIOStdio_clearerr,
2705     PerlIOStdio_setlinebuf,
2706 #ifdef FILE_base
2707     PerlIOStdio_get_base,
2708     PerlIOStdio_get_bufsiz,
2709 #else
2710     NULL,
2711     NULL,
2712 #endif
2713 #ifdef USE_STDIO_PTR
2714     PerlIOStdio_get_ptr,
2715     PerlIOStdio_get_cnt,
2716 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2717     PerlIOStdio_set_ptrcnt
2718 #else                           /* STDIO_PTR_LVALUE */
2719     NULL
2720 #endif                          /* STDIO_PTR_LVALUE */
2721 #else                           /* USE_STDIO_PTR */
2722     NULL,
2723     NULL,
2724     NULL
2725 #endif                          /* USE_STDIO_PTR */
2726 };
2727
2728 FILE *
2729 PerlIO_exportFILE(PerlIO *f, int fl)
2730 {
2731     dTHX;
2732     FILE *stdio;
2733     PerlIO_flush(f);
2734     stdio = fdopen(PerlIO_fileno(f), "r+");
2735     if (stdio) {
2736         PerlIOStdio *s =
2737             PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
2738                        PerlIOStdio);
2739         s->stdio = stdio;
2740     }
2741     return stdio;
2742 }
2743
2744 FILE *
2745 PerlIO_findFILE(PerlIO *f)
2746 {
2747     PerlIOl *l = *f;
2748     while (l) {
2749         if (l->tab == &PerlIO_stdio) {
2750             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2751             return s->stdio;
2752         }
2753         l = *PerlIONext(&l);
2754     }
2755     return PerlIO_exportFILE(f, 0);
2756 }
2757
2758 void
2759 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2760 {
2761 }
2762
2763 /*--------------------------------------------------------------------------------------*/
2764 /*
2765  * perlio buffer layer
2766  */
2767
2768 IV
2769 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2770 {
2771     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2772     int fd = PerlIO_fileno(f);
2773     Off_t posn;
2774     if (fd >= 0 && PerlLIO_isatty(fd)) {
2775         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
2776     }
2777     posn = PerlIO_tell(PerlIONext(f));
2778     if (posn != (Off_t) - 1) {
2779         b->posn = posn;
2780     }
2781     return PerlIOBase_pushed(aTHX_ f, mode, arg);
2782 }
2783
2784 PerlIO *
2785 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2786                IV n, const char *mode, int fd, int imode, int perm,
2787                PerlIO *f, int narg, SV **args)
2788 {
2789     if (f) {
2790         PerlIO *next = PerlIONext(f);
2791         PerlIO_funcs *tab =
2792             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
2793         next =
2794             (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2795                           next, narg, args);
2796         if (!next
2797             || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
2798             return NULL;
2799         }
2800     }
2801     else {
2802         PerlIO_funcs *tab =
2803             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
2804         int init = 0;
2805         if (*mode == 'I') {
2806             init = 1;
2807             /*
2808              * mode++;
2809              */
2810         }
2811         f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2812                           NULL, narg, args);
2813         if (f) {
2814             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
2815                 /*
2816                  * if push fails during open, open fails. close will pop us.
2817                  */
2818                 PerlIO_close (f);
2819                 return NULL;
2820             } else {
2821                 fd = PerlIO_fileno(f);
2822 #ifdef PERLIO_USING_CRLF
2823                 /*
2824                  * do something about failing setmode()? --jhi
2825                  */
2826                 PerlLIO_setmode(fd, O_BINARY);
2827 #endif
2828                 if (init && fd == 2) {
2829                     /*
2830                      * Initial stderr is unbuffered
2831                      */
2832                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2833                 }
2834             }
2835         }
2836     }
2837     return f;
2838 }
2839
2840 /*
2841  * This "flush" is akin to sfio's sync in that it handles files in either
2842  * read or write state
2843  */
2844 IV
2845 PerlIOBuf_flush(pTHX_ PerlIO *f)
2846 {
2847     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2848     int code = 0;
2849     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
2850         /*
2851          * write() the buffer
2852          */
2853         STDCHAR *buf = b->buf;
2854         STDCHAR *p = buf;
2855         PerlIO *n = PerlIONext(f);
2856         while (p < b->ptr) {
2857             SSize_t count = PerlIO_write(n, p, b->ptr - p);
2858             if (count > 0) {
2859                 p += count;
2860             }
2861             else if (count < 0 || PerlIO_error(n)) {
2862                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2863                 code = -1;
2864                 break;
2865             }
2866         }
2867         b->posn += (p - buf);
2868     }
2869     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2870         STDCHAR *buf = PerlIO_get_base(f);
2871         /*
2872          * Note position change
2873          */
2874         b->posn += (b->ptr - buf);
2875         if (b->ptr < b->end) {
2876             /*
2877              * We did not consume all of it
2878              */
2879             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) == 0) {
2880                 b->posn = PerlIO_tell(PerlIONext(f));
2881             }
2882         }
2883     }
2884     b->ptr = b->end = b->buf;
2885     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
2886     /*
2887      * FIXME: Is this right for read case ?
2888      */
2889     if (PerlIO_flush(PerlIONext(f)) != 0)
2890         code = -1;
2891     return code;
2892 }
2893
2894 IV
2895 PerlIOBuf_fill(pTHX_ PerlIO *f)
2896 {
2897     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2898     PerlIO *n = PerlIONext(f);
2899     SSize_t avail;
2900     /*
2901      * FIXME: doing the down-stream flush is a bad idea if it causes
2902      * pre-read data in stdio buffer to be discarded but this is too
2903      * simplistic - as it skips _our_ hosekeeping and breaks tell tests.
2904      * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { }
2905      */
2906     if (PerlIO_flush(f) != 0)
2907         return -1;
2908     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2909         PerlIOBase_flush_linebuf(aTHX);
2910
2911     if (!b->buf)
2912         PerlIO_get_base(f);     /* allocate via vtable */
2913
2914     b->ptr = b->end = b->buf;
2915     if (PerlIO_fast_gets(n)) {
2916         /*
2917          * Layer below is also buffered We do _NOT_ want to call its
2918          * ->Read() because that will loop till it gets what we asked for
2919          * which may hang on a pipe etc. Instead take anything it has to
2920          * hand, or ask it to fill _once_.
2921          */
2922         avail = PerlIO_get_cnt(n);
2923         if (avail <= 0) {
2924             avail = PerlIO_fill(n);
2925             if (avail == 0)
2926                 avail = PerlIO_get_cnt(n);
2927             else {
2928                 if (!PerlIO_error(n) && PerlIO_eof(n))
2929                     avail = 0;
2930             }
2931         }
2932         if (avail > 0) {
2933             STDCHAR *ptr = PerlIO_get_ptr(n);
2934             SSize_t cnt = avail;
2935             if (avail > b->bufsiz)
2936                 avail = b->bufsiz;
2937             Copy(ptr, b->buf, avail, STDCHAR);
2938             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
2939         }
2940     }
2941     else {
2942         avail = PerlIO_read(n, b->ptr, b->bufsiz);
2943     }
2944     if (avail <= 0) {
2945         if (avail == 0)
2946             PerlIOBase(f)->flags |= PERLIO_F_EOF;
2947         else
2948             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2949         return -1;
2950     }
2951     b->end = b->buf + avail;
2952     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2953     return 0;
2954 }
2955
2956 SSize_t
2957 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2958 {
2959     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2960     if (f) {
2961         if (!b->ptr)
2962             PerlIO_get_base(f);
2963         return PerlIOBase_read(aTHX_ f, vbuf, count);
2964     }
2965     return 0;
2966 }
2967
2968 SSize_t
2969 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2970 {
2971     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
2972     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2973     SSize_t unread = 0;
2974     SSize_t avail;
2975     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2976         PerlIO_flush(f);
2977     if (!b->buf)
2978         PerlIO_get_base(f);
2979     if (b->buf) {
2980         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2981             /*
2982              * Buffer is already a read buffer, we can overwrite any chars
2983              * which have been read back to buffer start
2984              */
2985             avail = (b->ptr - b->buf);
2986         }
2987         else {
2988             /*
2989              * Buffer is idle, set it up so whole buffer is available for
2990              * unread
2991              */
2992             avail = b->bufsiz;
2993             b->end = b->buf + avail;
2994             b->ptr = b->end;
2995             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2996             /*
2997              * Buffer extends _back_ from where we are now
2998              */
2999             b->posn -= b->bufsiz;
3000         }
3001         if (avail > (SSize_t) count) {
3002             /*
3003              * If we have space for more than count, just move count
3004              */
3005             avail = count;
3006         }
3007         if (avail > 0) {
3008             b->ptr -= avail;
3009             buf -= avail;
3010             /*
3011              * In simple stdio-like ungetc() case chars will be already
3012              * there
3013              */
3014             if (buf != b->ptr) {
3015                 Copy(buf, b->ptr, avail, STDCHAR);
3016             }
3017             count -= avail;
3018             unread += avail;
3019             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3020         }
3021     }
3022     return unread;
3023 }
3024
3025 SSize_t
3026 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3027 {
3028     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3029     const STDCHAR *buf = (const STDCHAR *) vbuf;
3030     Size_t written = 0;
3031     if (!b->buf)
3032         PerlIO_get_base(f);
3033     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3034         return 0;
3035     while (count > 0) {
3036         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3037         if ((SSize_t) count < avail)
3038             avail = count;
3039         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3040         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3041             while (avail > 0) {
3042                 int ch = *buf++;
3043                 *(b->ptr)++ = ch;
3044                 count--;
3045                 avail--;
3046                 written++;
3047                 if (ch == '\n') {
3048                     PerlIO_flush(f);
3049                     break;
3050                 }
3051             }
3052         }
3053         else {
3054             if (avail) {
3055                 Copy(buf, b->ptr, avail, STDCHAR);
3056                 count -= avail;
3057                 buf += avail;
3058                 written += avail;
3059                 b->ptr += avail;
3060             }
3061         }
3062         if (b->ptr >= (b->buf + b->bufsiz))
3063             PerlIO_flush(f);
3064     }
3065     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3066         PerlIO_flush(f);
3067     return written;
3068 }
3069
3070 IV
3071 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3072 {
3073     IV code;
3074     if ((code = PerlIO_flush(f)) == 0) {
3075         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3076         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3077         code = PerlIO_seek(PerlIONext(f), offset, whence);
3078         if (code == 0) {
3079             b->posn = PerlIO_tell(PerlIONext(f));
3080         }
3081     }
3082     return code;
3083 }
3084
3085 Off_t
3086 PerlIOBuf_tell(pTHX_ PerlIO *f)
3087 {
3088     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3089     /*
3090      * b->posn is file position where b->buf was read, or will be written
3091      */
3092     Off_t posn = b->posn;
3093     if (b->buf) {
3094         /*
3095          * If buffer is valid adjust position by amount in buffer
3096          */
3097         posn += (b->ptr - b->buf);
3098     }
3099     return posn;
3100 }
3101
3102 IV
3103 PerlIOBuf_close(pTHX_ PerlIO *f)
3104 {
3105     IV code = PerlIOBase_close(aTHX_ f);
3106     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3107     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3108         Safefree(b->buf);
3109     }
3110     b->buf = NULL;
3111     b->ptr = b->end = b->buf;
3112     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3113     return code;
3114 }
3115
3116 STDCHAR *
3117 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3118 {
3119     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3120     if (!b->buf)
3121         PerlIO_get_base(f);
3122     return b->ptr;
3123 }
3124
3125 SSize_t
3126 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3127 {
3128     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3129     if (!b->buf)
3130         PerlIO_get_base(f);
3131     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3132         return (b->end - b->ptr);
3133     return 0;
3134 }
3135
3136 STDCHAR *
3137 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3138 {
3139     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3140     if (!b->buf) {
3141         if (!b->bufsiz)
3142             b->bufsiz = 4096;
3143         b->buf =
3144         Newz('B',b->buf,b->bufsiz, STDCHAR);
3145         if (!b->buf) {
3146             b->buf = (STDCHAR *) & b->oneword;
3147             b->bufsiz = sizeof(b->oneword);
3148         }
3149         b->ptr = b->buf;
3150         b->end = b->ptr;
3151     }
3152     return b->buf;
3153 }
3154
3155 Size_t
3156 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3157 {
3158     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3159     if (!b->buf)
3160         PerlIO_get_base(f);
3161     return (b->end - b->buf);
3162 }
3163
3164 void
3165 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3166 {
3167     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3168     if (!b->buf)
3169         PerlIO_get_base(f);
3170     b->ptr = ptr;
3171     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3172         assert(PerlIO_get_cnt(f) == cnt);
3173         assert(b->ptr >= b->buf);
3174     }
3175     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3176 }
3177
3178 PerlIO *
3179 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3180 {
3181  return PerlIOBase_dup(aTHX_ f, o, param, flags);
3182 }
3183
3184
3185
3186 PerlIO_funcs PerlIO_perlio = {
3187     "perlio",
3188     sizeof(PerlIOBuf),
3189     PERLIO_K_BUFFERED,
3190     PerlIOBuf_pushed,
3191     PerlIOBase_noop_ok,
3192     PerlIOBuf_open,
3193     NULL,
3194     PerlIOBase_fileno,
3195     PerlIOBuf_dup,
3196     PerlIOBuf_read,
3197     PerlIOBuf_unread,
3198     PerlIOBuf_write,
3199     PerlIOBuf_seek,
3200     PerlIOBuf_tell,
3201     PerlIOBuf_close,
3202     PerlIOBuf_flush,
3203     PerlIOBuf_fill,
3204     PerlIOBase_eof,
3205     PerlIOBase_error,
3206     PerlIOBase_clearerr,
3207     PerlIOBase_setlinebuf,
3208     PerlIOBuf_get_base,
3209     PerlIOBuf_bufsiz,
3210     PerlIOBuf_get_ptr,
3211     PerlIOBuf_get_cnt,
3212     PerlIOBuf_set_ptrcnt,
3213 };
3214
3215 /*--------------------------------------------------------------------------------------*/
3216 /*
3217  * Temp layer to hold unread chars when cannot do it any other way
3218  */
3219
3220 IV
3221 PerlIOPending_fill(pTHX_ PerlIO *f)
3222 {
3223     /*
3224      * Should never happen
3225      */
3226     PerlIO_flush(f);
3227     return 0;
3228 }
3229
3230 IV
3231 PerlIOPending_close(pTHX_ PerlIO *f)
3232 {
3233     /*
3234      * A tad tricky - flush pops us, then we close new top
3235      */
3236     PerlIO_flush(f);
3237     return PerlIO_close(f);
3238 }
3239
3240 IV
3241 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3242 {
3243     /*
3244      * A tad tricky - flush pops us, then we seek new top
3245      */
3246     PerlIO_flush(f);
3247     return PerlIO_seek(f, offset, whence);
3248 }
3249
3250
3251 IV
3252 PerlIOPending_flush(pTHX_ PerlIO *f)
3253 {
3254     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3255     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3256         Safefree(b->buf);
3257         b->buf = NULL;
3258     }
3259     PerlIO_pop(aTHX_ f);
3260     return 0;
3261 }
3262
3263 void
3264 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3265 {
3266     if (cnt <= 0) {
3267         PerlIO_flush(f);
3268     }
3269     else {
3270         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3271     }
3272 }
3273
3274 IV
3275 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3276 {
3277     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
3278     PerlIOl *l = PerlIOBase(f);
3279     /*
3280      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3281      * etc. get muddled when it changes mid-string when we auto-pop.
3282      */
3283     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3284         (PerlIOBase(PerlIONext(f))->
3285          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3286     return code;
3287 }
3288
3289 SSize_t
3290 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3291 {
3292     SSize_t avail = PerlIO_get_cnt(f);
3293     SSize_t got = 0;
3294     if (count < avail)
3295         avail = count;
3296     if (avail > 0)
3297         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3298     if (got >= 0 && got < count) {
3299         SSize_t more =
3300             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3301         if (more >= 0 || got == 0)
3302             got += more;
3303     }
3304     return got;
3305 }
3306
3307 PerlIO_funcs PerlIO_pending = {
3308     "pending",
3309     sizeof(PerlIOBuf),
3310     PERLIO_K_BUFFERED,
3311     PerlIOPending_pushed,
3312     PerlIOBase_noop_ok,
3313     NULL,
3314     NULL,
3315     PerlIOBase_fileno,
3316     PerlIOBuf_dup,
3317     PerlIOPending_read,
3318     PerlIOBuf_unread,
3319     PerlIOBuf_write,
3320     PerlIOPending_seek,
3321     PerlIOBuf_tell,
3322     PerlIOPending_close,
3323     PerlIOPending_flush,
3324     PerlIOPending_fill,
3325     PerlIOBase_eof,
3326     PerlIOBase_error,
3327     PerlIOBase_clearerr,
3328     PerlIOBase_setlinebuf,
3329     PerlIOBuf_get_base,
3330     PerlIOBuf_bufsiz,
3331     PerlIOBuf_get_ptr,
3332     PerlIOBuf_get_cnt,
3333     PerlIOPending_set_ptrcnt,
3334 };
3335
3336
3337
3338 /*--------------------------------------------------------------------------------------*/
3339 /*
3340  * crlf - translation On read translate CR,LF to "\n" we do this by
3341  * overriding ptr/cnt entries to hand back a line at a time and keeping a
3342  * record of which nl we "lied" about. On write translate "\n" to CR,LF
3343  */
3344
3345 typedef struct {
3346     PerlIOBuf base;             /* PerlIOBuf stuff */
3347     STDCHAR *nl;                /* Position of crlf we "lied" about in the
3348                                  * buffer */
3349 } PerlIOCrlf;
3350
3351 IV
3352 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3353 {
3354     IV code;
3355     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3356     code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
3357 #if 0
3358     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3359                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3360                  PerlIOBase(f)->flags);
3361 #endif
3362     return code;
3363 }
3364
3365
3366 SSize_t
3367 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3368 {
3369     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3370     if (c->nl) {
3371         *(c->nl) = 0xd;
3372         c->nl = NULL;
3373     }
3374     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3375         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3376     else {
3377         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3378         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3379         SSize_t unread = 0;
3380         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3381             PerlIO_flush(f);
3382         if (!b->buf)
3383             PerlIO_get_base(f);
3384         if (b->buf) {
3385             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3386                 b->end = b->ptr = b->buf + b->bufsiz;
3387                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3388                 b->posn -= b->bufsiz;
3389             }
3390             while (count > 0 && b->ptr > b->buf) {
3391                 int ch = *--buf;
3392                 if (ch == '\n') {
3393                     if (b->ptr - 2 >= b->buf) {
3394                         *--(b->ptr) = 0xa;
3395                         *--(b->ptr) = 0xd;
3396                         unread++;
3397                         count--;
3398                     }
3399                     else {
3400                         buf++;
3401                         break;
3402                     }
3403                 }
3404                 else {
3405                     *--(b->ptr) = ch;
3406                     unread++;
3407                     count--;
3408                 }
3409             }
3410         }
3411         return unread;
3412     }
3413 }
3414
3415 SSize_t
3416 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3417 {
3418     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3419     if (!b->buf)
3420         PerlIO_get_base(f);
3421     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3422         PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3423         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl) {
3424             STDCHAR *nl = b->ptr;
3425           scan:
3426             while (nl < b->end && *nl != 0xd)
3427                 nl++;
3428             if (nl < b->end && *nl == 0xd) {
3429               test:
3430                 if (nl + 1 < b->end) {
3431                     if (nl[1] == 0xa) {
3432                         *nl = '\n';
3433                         c->nl = nl;
3434                     }
3435                     else {
3436                         /*
3437                          * Not CR,LF but just CR
3438                          */
3439                         nl++;
3440                         goto scan;
3441                     }
3442                 }
3443                 else {
3444                     /*
3445                      * Blast - found CR as last char in buffer
3446                      */
3447
3448                     if (b->ptr < nl) {
3449                         /*
3450                          * They may not care, defer work as long as
3451                          * possible
3452                          */
3453                         c->nl = nl;
3454                         return (nl - b->ptr);
3455                     }
3456                     else {
3457                         int code;
3458                         b->ptr++;       /* say we have read it as far as
3459                                          * flush() is concerned */
3460                         b->buf++;       /* Leave space in front of buffer */
3461                         b->bufsiz--;    /* Buffer is thus smaller */
3462                         code = PerlIO_fill(f);  /* Fetch some more */
3463                         b->bufsiz++;    /* Restore size for next time */
3464                         b->buf--;       /* Point at space */
3465                         b->ptr = nl = b->buf;   /* Which is what we hand
3466                                                  * off */
3467                         b->posn--;      /* Buffer starts here */
3468                         *nl = 0xd;      /* Fill in the CR */
3469                         if (code == 0)
3470                             goto test;  /* fill() call worked */
3471                         /*
3472                          * CR at EOF - just fall through
3473                          */
3474                         /* Should we clear EOF though ??? */
3475                     }
3476                 }
3477             }
3478         }
3479         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3480     }
3481     return 0;
3482 }
3483
3484 void
3485 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3486 {
3487     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3488     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3489     IV flags = PerlIOBase(f)->flags;
3490     if (!b->buf)
3491         PerlIO_get_base(f);
3492     if (!ptr) {
3493         if (c->nl) {
3494             ptr = c->nl + 1;
3495             if (ptr == b->end && *c->nl == 0xd) {
3496                 /* Defered CR at end of buffer case - we lied about count */
3497                 ptr--;  
3498             }
3499         }
3500         else {
3501             ptr = b->end;
3502         }
3503         ptr -= cnt;
3504     }
3505     else {
3506         /*
3507          * Test code - delete when it works ...
3508          */
3509         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
3510         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3511           /* Defered CR at end of buffer case - we lied about count */
3512           chk--;
3513         }
3514         chk -= cnt;
3515
3516         if (ptr != chk ) {
3517             Perl_warn(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3518                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3519                        b->end, cnt);
3520         }
3521     }
3522     if (c->nl) {
3523         if (ptr > c->nl) {
3524             /*
3525              * They have taken what we lied about
3526              */
3527             *(c->nl) = 0xd;
3528             c->nl = NULL;
3529             ptr++;
3530         }
3531     }
3532     b->ptr = ptr;
3533     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3534 }
3535
3536 SSize_t
3537 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3538 {
3539     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3540         return PerlIOBuf_write(aTHX_ f, vbuf, count);
3541     else {
3542         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3543         const STDCHAR *buf = (const STDCHAR *) vbuf;
3544         const STDCHAR *ebuf = buf + count;
3545         if (!b->buf)
3546             PerlIO_get_base(f);
3547         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3548             return 0;
3549         while (buf < ebuf) {
3550             STDCHAR *eptr = b->buf + b->bufsiz;
3551             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3552             while (buf < ebuf && b->ptr < eptr) {
3553                 if (*buf == '\n') {
3554                     if ((b->ptr + 2) > eptr) {
3555                         /*
3556                          * Not room for both
3557                          */
3558                         PerlIO_flush(f);
3559                         break;
3560                     }
3561                     else {
3562                         *(b->ptr)++ = 0xd;      /* CR */
3563                         *(b->ptr)++ = 0xa;      /* LF */
3564                         buf++;
3565                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3566                             PerlIO_flush(f);
3567                             break;
3568                         }
3569                     }
3570                 }
3571                 else {
3572                     int ch = *buf++;
3573                     *(b->ptr)++ = ch;
3574                 }
3575                 if (b->ptr >= eptr) {
3576                     PerlIO_flush(f);
3577                     break;
3578                 }
3579             }
3580         }
3581         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3582             PerlIO_flush(f);
3583         return (buf - (STDCHAR *) vbuf);
3584     }
3585 }
3586
3587 IV
3588 PerlIOCrlf_flush(pTHX_ PerlIO *f)
3589 {
3590     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3591     if (c->nl) {
3592         *(c->nl) = 0xd;
3593         c->nl = NULL;
3594     }
3595     return PerlIOBuf_flush(aTHX_ f);
3596 }
3597
3598 PerlIO_funcs PerlIO_crlf = {
3599     "crlf",
3600     sizeof(PerlIOCrlf),
3601     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3602     PerlIOCrlf_pushed,
3603     PerlIOBase_noop_ok,         /* popped */
3604     PerlIOBuf_open,
3605     NULL,
3606     PerlIOBase_fileno,
3607     PerlIOBuf_dup,
3608     PerlIOBuf_read,             /* generic read works with ptr/cnt lies
3609                                  * ... */
3610     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
3611     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
3612     PerlIOBuf_seek,
3613     PerlIOBuf_tell,
3614     PerlIOBuf_close,
3615     PerlIOCrlf_flush,
3616     PerlIOBuf_fill,
3617     PerlIOBase_eof,
3618     PerlIOBase_error,
3619     PerlIOBase_clearerr,
3620     PerlIOBase_setlinebuf,
3621     PerlIOBuf_get_base,
3622     PerlIOBuf_bufsiz,
3623     PerlIOBuf_get_ptr,
3624     PerlIOCrlf_get_cnt,
3625     PerlIOCrlf_set_ptrcnt,
3626 };
3627
3628 #ifdef HAS_MMAP
3629 /*--------------------------------------------------------------------------------------*/
3630 /*
3631  * mmap as "buffer" layer
3632  */
3633
3634 typedef struct {
3635     PerlIOBuf base;             /* PerlIOBuf stuff */
3636     Mmap_t mptr;                /* Mapped address */
3637     Size_t len;                 /* mapped length */
3638     STDCHAR *bbuf;              /* malloced buffer if map fails */
3639 } PerlIOMmap;
3640
3641 static size_t page_size = 0;
3642
3643 IV
3644 PerlIOMmap_map(pTHX_ PerlIO *f)
3645 {
3646     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3647     IV flags = PerlIOBase(f)->flags;
3648     IV code = 0;
3649     if (m->len)
3650         abort();
3651     if (flags & PERLIO_F_CANREAD) {
3652         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3653         int fd = PerlIO_fileno(f);
3654         Stat_t st;
3655         code = Fstat(fd, &st);
3656         if (code == 0 && S_ISREG(st.st_mode)) {
3657             SSize_t len = st.st_size - b->posn;
3658             if (len > 0) {
3659                 Off_t posn;
3660                 if (!page_size) {
3661 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3662                     {
3663                         SETERRNO(0, SS$_NORMAL);
3664 #   ifdef _SC_PAGESIZE
3665                         page_size = sysconf(_SC_PAGESIZE);
3666 #   else
3667                         page_size = sysconf(_SC_PAGE_SIZE);
3668 #   endif
3669                         if ((long) page_size < 0) {
3670                             if (errno) {
3671                                 SV *error = ERRSV;
3672                                 char *msg;
3673                                 STRLEN n_a;
3674                                 (void) SvUPGRADE(error, SVt_PV);
3675                                 msg = SvPVx(error, n_a);
3676                                 Perl_croak(aTHX_ "panic: sysconf: %s",
3677                                            msg);
3678                             }
3679                             else
3680                                 Perl_croak(aTHX_
3681                                            "panic: sysconf: pagesize unknown");
3682                         }
3683                     }
3684 #else
3685 #   ifdef HAS_GETPAGESIZE
3686                     page_size = getpagesize();
3687 #   else
3688 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3689                     page_size = PAGESIZE;       /* compiletime, bad */
3690 #       endif
3691 #   endif
3692 #endif
3693                     if ((IV) page_size <= 0)
3694                         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3695                                    (IV) page_size);
3696                 }
3697                 if (b->posn < 0) {
3698                     /*
3699                      * This is a hack - should never happen - open should
3700                      * have set it !
3701                      */
3702                     b->posn = PerlIO_tell(PerlIONext(f));
3703                 }
3704                 posn = (b->posn / page_size) * page_size;
3705                 len = st.st_size - posn;
3706                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3707                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3708 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3709                     madvise(m->mptr, len, MADV_SEQUENTIAL);
3710 #endif
3711 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3712                     madvise(m->mptr, len, MADV_WILLNEED);
3713 #endif
3714                     PerlIOBase(f)->flags =
3715                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3716                     b->end = ((STDCHAR *) m->mptr) + len;
3717                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3718                     b->ptr = b->buf;
3719                     m->len = len;
3720                 }
3721                 else {
3722                     b->buf = NULL;
3723                 }
3724             }
3725             else {
3726                 PerlIOBase(f)->flags =
3727                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3728                 b->buf = NULL;
3729                 b->ptr = b->end = b->ptr;
3730                 code = -1;
3731             }
3732         }
3733     }
3734     return code;
3735 }
3736
3737 IV
3738 PerlIOMmap_unmap(pTHX_ PerlIO *f)
3739 {
3740     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3741     PerlIOBuf *b = &m->base;
3742     IV code = 0;
3743     if (m->len) {
3744         if (b->buf) {
3745             code = munmap(m->mptr, m->len);
3746             b->buf = NULL;
3747             m->len = 0;
3748             m->mptr = NULL;
3749             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
3750                 code = -1;
3751         }
3752         b->ptr = b->end = b->buf;
3753         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3754     }
3755     return code;
3756 }
3757
3758 STDCHAR *
3759 PerlIOMmap_get_base(pTHX_ PerlIO *f)
3760 {
3761     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3762     PerlIOBuf *b = &m->base;
3763     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3764         /*
3765          * Already have a readbuffer in progress
3766          */
3767         return b->buf;
3768     }
3769     if (b->buf) {
3770         /*
3771          * We have a write buffer or flushed PerlIOBuf read buffer
3772          */
3773         m->bbuf = b->buf;       /* save it in case we need it again */
3774         b->buf = NULL;          /* Clear to trigger below */
3775     }
3776     if (!b->buf) {
3777         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
3778         if (!b->buf) {
3779             /*
3780              * Map did not work - recover PerlIOBuf buffer if we have one
3781              */
3782             b->buf = m->bbuf;
3783         }
3784     }
3785     b->ptr = b->end = b->buf;
3786     if (b->buf)
3787         return b->buf;
3788     return PerlIOBuf_get_base(aTHX_ f);
3789 }
3790
3791 SSize_t
3792 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3793 {
3794     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3795     PerlIOBuf *b = &m->base;
3796     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3797         PerlIO_flush(f);
3798     if (b->ptr && (b->ptr - count) >= b->buf
3799         && memEQ(b->ptr - count, vbuf, count)) {
3800         b->ptr -= count;
3801         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3802         return count;
3803     }
3804     if (m->len) {
3805         /*
3806          * Loose the unwritable mapped buffer
3807          */
3808         PerlIO_flush(f);
3809         /*
3810          * If flush took the "buffer" see if we have one from before
3811          */
3812         if (!b->buf && m->bbuf)
3813             b->buf = m->bbuf;
3814         if (!b->buf) {
3815             PerlIOBuf_get_base(aTHX_ f);
3816             m->bbuf = b->buf;
3817         }
3818     }
3819     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3820 }
3821
3822 SSize_t
3823 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3824 {
3825     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3826     PerlIOBuf *b = &m->base;
3827     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3828         /*
3829          * No, or wrong sort of, buffer
3830          */
3831         if (m->len) {
3832             if (PerlIOMmap_unmap(aTHX_ f) != 0)
3833                 return 0;
3834         }
3835         /*
3836          * If unmap took the "buffer" see if we have one from before
3837          */
3838         if (!b->buf && m->bbuf)
3839             b->buf = m->bbuf;
3840         if (!b->buf) {
3841             PerlIOBuf_get_base(aTHX_ f);
3842             m->bbuf = b->buf;
3843         }
3844     }
3845     return PerlIOBuf_write(aTHX_ f, vbuf, count);
3846 }
3847
3848 IV
3849 PerlIOMmap_flush(pTHX_ PerlIO *f)
3850 {
3851     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3852     PerlIOBuf *b = &m->base;
3853     IV code = PerlIOBuf_flush(aTHX_ f);
3854     /*
3855      * Now we are "synced" at PerlIOBuf level
3856      */
3857     if (b->buf) {
3858         if (m->len) {
3859             /*
3860              * Unmap the buffer
3861              */
3862             if (PerlIOMmap_unmap(aTHX_ f) != 0)
3863                 code = -1;
3864         }
3865         else {
3866             /*
3867              * We seem to have a PerlIOBuf buffer which was not mapped
3868              * remember it in case we need one later
3869              */
3870             m->bbuf = b->buf;
3871         }
3872     }
3873     return code;
3874 }
3875
3876 IV
3877 PerlIOMmap_fill(pTHX_ PerlIO *f)
3878 {
3879     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3880     IV code = PerlIO_flush(f);
3881     if (code == 0 && !b->buf) {
3882         code = PerlIOMmap_map(aTHX_ f);
3883     }
3884     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3885         code = PerlIOBuf_fill(aTHX_ f);
3886     }
3887     return code;
3888 }
3889
3890 IV
3891 PerlIOMmap_close(pTHX_ PerlIO *f)
3892 {
3893     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3894     PerlIOBuf *b = &m->base;
3895     IV code = PerlIO_flush(f);
3896     if (m->bbuf) {
3897         b->buf = m->bbuf;
3898         m->bbuf = NULL;
3899         b->ptr = b->end = b->buf;
3900     }
3901     if (PerlIOBuf_close(aTHX_ f) != 0)
3902         code = -1;
3903     return code;
3904 }
3905
3906 PerlIO *
3907 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3908 {
3909  return PerlIOBase_dup(aTHX_ f, o, param, flags);
3910 }
3911
3912
3913 PerlIO_funcs PerlIO_mmap = {
3914     "mmap",
3915     sizeof(PerlIOMmap),
3916     PERLIO_K_BUFFERED,
3917     PerlIOBuf_pushed,
3918     PerlIOBase_noop_ok,
3919     PerlIOBuf_open,
3920     NULL,
3921     PerlIOBase_fileno,
3922     PerlIOMmap_dup,
3923     PerlIOBuf_read,
3924     PerlIOMmap_unread,
3925     PerlIOMmap_write,
3926     PerlIOBuf_seek,
3927     PerlIOBuf_tell,
3928     PerlIOBuf_close,
3929     PerlIOMmap_flush,
3930     PerlIOMmap_fill,
3931     PerlIOBase_eof,
3932     PerlIOBase_error,
3933     PerlIOBase_clearerr,
3934     PerlIOBase_setlinebuf,
3935     PerlIOMmap_get_base,
3936     PerlIOBuf_bufsiz,
3937     PerlIOBuf_get_ptr,
3938     PerlIOBuf_get_cnt,
3939     PerlIOBuf_set_ptrcnt,
3940 };
3941
3942 #endif                          /* HAS_MMAP */
3943
3944 PerlIO *
3945 Perl_PerlIO_stdin(pTHX)
3946 {
3947     if (!PL_perlio) {
3948         PerlIO_stdstreams(aTHX);
3949     }
3950     return &PL_perlio[1];
3951 }
3952
3953 PerlIO *
3954 Perl_PerlIO_stdout(pTHX)
3955 {
3956     if (!PL_perlio) {
3957         PerlIO_stdstreams(aTHX);
3958     }
3959     return &PL_perlio[2];
3960 }
3961
3962 PerlIO *
3963 Perl_PerlIO_stderr(pTHX)
3964 {
3965     if (!PL_perlio) {
3966         PerlIO_stdstreams(aTHX);
3967     }
3968     return &PL_perlio[3];
3969 }
3970
3971 /*--------------------------------------------------------------------------------------*/
3972
3973 char *
3974 PerlIO_getname(PerlIO *f, char *buf)
3975 {
3976     dTHX;
3977     char *name = NULL;
3978 #ifdef VMS
3979     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3980     if (stdio)
3981         name = fgetname(stdio, buf);
3982 #else
3983     Perl_croak(aTHX_ "Don't know how to get file name");
3984 #endif
3985     return name;
3986 }
3987
3988
3989 /*--------------------------------------------------------------------------------------*/
3990 /*
3991  * Functions which can be called on any kind of PerlIO implemented in
3992  * terms of above
3993  */
3994
3995 #undef PerlIO_fdopen
3996 PerlIO *
3997 PerlIO_fdopen(int fd, const char *mode)
3998 {
3999     dTHX;
4000     return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4001 }
4002
4003 #undef PerlIO_open
4004 PerlIO *
4005 PerlIO_open(const char *path, const char *mode)
4006 {
4007     dTHX;
4008     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4009     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4010 }
4011
4012 #undef Perlio_reopen
4013 PerlIO *
4014 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4015 {
4016     dTHX;
4017     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4018     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4019 }
4020
4021 #undef PerlIO_getc
4022 int
4023 PerlIO_getc(PerlIO *f)
4024 {
4025     dTHX;
4026     STDCHAR buf[1];
4027     SSize_t count = PerlIO_read(f, buf, 1);
4028     if (count == 1) {
4029         return (unsigned char) buf[0];
4030     }
4031     return EOF;
4032 }
4033
4034 #undef PerlIO_ungetc
4035 int
4036 PerlIO_ungetc(PerlIO *f, int ch)
4037 {
4038     dTHX;
4039     if (ch != EOF) {
4040         STDCHAR buf = ch;
4041         if (PerlIO_unread(f, &buf, 1) == 1)
4042             return ch;
4043     }
4044     return EOF;
4045 }
4046
4047 #undef PerlIO_putc
4048 int
4049 PerlIO_putc(PerlIO *f, int ch)
4050 {
4051     dTHX;
4052     STDCHAR buf = ch;
4053     return PerlIO_write(f, &buf, 1);
4054 }
4055
4056 #undef PerlIO_puts
4057 int
4058 PerlIO_puts(PerlIO *f, const char *s)
4059 {
4060     dTHX;
4061     STRLEN len = strlen(s);
4062     return PerlIO_write(f, s, len);
4063 }
4064
4065 #undef PerlIO_rewind
4066 void
4067 PerlIO_rewind(PerlIO *f)
4068 {
4069     dTHX;
4070     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4071     PerlIO_clearerr(f);
4072 }
4073
4074 #undef PerlIO_vprintf
4075 int
4076 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4077 {
4078     dTHX;
4079     SV *sv = newSVpvn("", 0);
4080     char *s;
4081     STRLEN len;
4082     SSize_t wrote;
4083 #ifdef NEED_VA_COPY
4084     va_list apc;
4085     Perl_va_copy(ap, apc);
4086     sv_vcatpvf(sv, fmt, &apc);
4087 #else
4088     sv_vcatpvf(sv, fmt, &ap);
4089 #endif
4090     s = SvPV(sv, len);
4091     wrote = PerlIO_write(f, s, len);
4092     SvREFCNT_dec(sv);
4093     return wrote;
4094 }
4095
4096 #undef PerlIO_printf
4097 int
4098 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4099 {
4100     va_list ap;
4101     int result;
4102     va_start(ap, fmt);
4103     result = PerlIO_vprintf(f, fmt, ap);
4104     va_end(ap);
4105     return result;
4106 }
4107
4108 #undef PerlIO_stdoutf
4109 int
4110 PerlIO_stdoutf(const char *fmt, ...)
4111 {
4112     dTHX;
4113     va_list ap;
4114     int result;
4115     va_start(ap, fmt);
4116     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4117     va_end(ap);
4118     return result;
4119 }
4120
4121 #undef PerlIO_tmpfile
4122 PerlIO *
4123 PerlIO_tmpfile(void)
4124 {
4125     /*
4126      * I have no idea how portable mkstemp() is ...
4127      */
4128 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4129     dTHX;
4130     PerlIO *f = NULL;
4131     FILE *stdio = PerlSIO_tmpfile();
4132     if (stdio) {
4133         PerlIOStdio *s =
4134             PerlIOSelf(PerlIO_push
4135                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4136                         "w+", Nullsv), PerlIOStdio);
4137         s->stdio = stdio;
4138     }
4139     return f;
4140 #else
4141     dTHX;
4142     SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4143     int fd = mkstemp(SvPVX(sv));
4144     PerlIO *f = NULL;
4145     if (fd >= 0) {
4146         f = PerlIO_fdopen(fd, "w+");
4147         if (f) {
4148             PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4149         }
4150         PerlLIO_unlink(SvPVX(sv));
4151         SvREFCNT_dec(sv);
4152     }
4153     return f;
4154 #endif
4155 }
4156
4157 #undef HAS_FSETPOS
4158 #undef HAS_FGETPOS
4159
4160 #endif                          /* USE_SFIO */
4161 #endif                          /* PERLIO_IS_STDIO */
4162
4163 /*======================================================================================*/
4164 /*
4165  * Now some functions in terms of above which may be needed even if we are
4166  * not in true PerlIO mode
4167  */
4168
4169 #ifndef HAS_FSETPOS
4170 #undef PerlIO_setpos
4171 int
4172 PerlIO_setpos(PerlIO *f, SV *pos)
4173 {
4174     dTHX;
4175     if (SvOK(pos)) {
4176         STRLEN len;
4177         Off_t *posn = (Off_t *) SvPV(pos, len);
4178         if (f && len == sizeof(Off_t))
4179             return PerlIO_seek(f, *posn, SEEK_SET);
4180     }
4181     SETERRNO(EINVAL, SS$_IVCHAN);
4182     return -1;
4183 }
4184 #else
4185 #undef PerlIO_setpos
4186 int
4187 PerlIO_setpos(PerlIO *f, SV *pos)
4188 {
4189     dTHX;
4190     if (SvOK(pos)) {
4191         STRLEN len;
4192         Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4193         if (f && len == sizeof(Fpos_t)) {
4194 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4195             return fsetpos64(f, fpos);
4196 #else
4197             return fsetpos(f, fpos);
4198 #endif
4199         }
4200     }
4201     SETERRNO(EINVAL, SS$_IVCHAN);
4202     return -1;
4203 }
4204 #endif
4205
4206 #ifndef HAS_FGETPOS
4207 #undef PerlIO_getpos
4208 int
4209 PerlIO_getpos(PerlIO *f, SV *pos)
4210 {
4211     dTHX;
4212     Off_t posn = PerlIO_tell(f);
4213     sv_setpvn(pos, (char *) &posn, sizeof(posn));
4214     return (posn == (Off_t) - 1) ? -1 : 0;
4215 }
4216 #else
4217 #undef PerlIO_getpos
4218 int
4219 PerlIO_getpos(PerlIO *f, SV *pos)
4220 {
4221     dTHX;
4222     Fpos_t fpos;
4223     int code;
4224 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4225     code = fgetpos64(f, &fpos);
4226 #else
4227     code = fgetpos(f, &fpos);
4228 #endif
4229     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4230     return code;
4231 }
4232 #endif
4233
4234 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4235
4236 int
4237 vprintf(char *pat, char *args)
4238 {
4239     _doprnt(pat, args, stdout);
4240     return 0;                   /* wrong, but perl doesn't use the return
4241                                  * value */
4242 }
4243
4244 int
4245 vfprintf(FILE *fd, char *pat, char *args)
4246 {
4247     _doprnt(pat, args, fd);
4248     return 0;                   /* wrong, but perl doesn't use the return
4249                                  * value */
4250 }
4251
4252 #endif
4253
4254 #ifndef PerlIO_vsprintf
4255 int
4256 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4257 {
4258     int val = vsprintf(s, fmt, ap);
4259     if (n >= 0) {
4260         if (strlen(s) >= (STRLEN) n) {
4261             dTHX;
4262             (void) PerlIO_puts(Perl_error_log,
4263                                "panic: sprintf overflow - memory corrupted!\n");
4264             my_exit(1);
4265         }
4266     }
4267     return val;
4268 }
4269 #endif
4270
4271 #ifndef PerlIO_sprintf
4272 int
4273 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4274 {
4275     va_list ap;
4276     int result;
4277     va_start(ap, fmt);
4278     result = PerlIO_vsprintf(s, n, fmt, ap);
4279     va_end(ap);
4280     return result;
4281 }
4282 #endif
4283
4284
4285
4286
4287