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