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