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