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