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