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