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