Define PerlIOBase_open
[perl.git] / perlio.c
1 /*
2  * perlio.c
3  * Copyright (c) 1996-2006, Nick Ing-Simmons
4  * Copyright (c) 2006, 2007, 2008 Larry Wall and others
5  *
6  * You may distribute under the terms of either the GNU General Public License
7  * or the Artistic License, as specified in the README file.
8  */
9
10 /*
11  * Hour after hour for nearly three weary days he had jogged up and down,
12  * over passes, and through long dales, and across many streams.
13  *
14  *     [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
15  */
16
17 /* This file contains the functions needed to implement PerlIO, which
18  * is Perl's private replacement for the C stdio library. This is used
19  * by default unless you compile with -Uuseperlio or run with
20  * PERLIO=:stdio (but don't do this unless you know what you're doing)
21  */
22
23 /*
24  * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25  * at the dispatch tables, even when we do not need it for other reasons.
26  * Invent a dSYS macro to abstract this out
27  */
28 #ifdef PERL_IMPLICIT_SYS
29 #define dSYS dTHX
30 #else
31 #define dSYS dNOOP
32 #endif
33
34 #define VOIDUSED 1
35 #ifdef PERL_MICRO
36 #   include "uconfig.h"
37 #else
38 #   ifndef USE_CROSS_COMPILE
39 #       include "config.h"
40 #   else
41 #       include "xconfig.h"
42 #   endif
43 #endif
44
45 #define PERLIO_NOT_STDIO 0
46 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
47 /*
48  * #define PerlIO FILE
49  */
50 #endif
51 /*
52  * This file provides those parts of PerlIO abstraction
53  * which are not #defined in perlio.h.
54  * Which these are depends on various Configure #ifdef's
55  */
56
57 #include "EXTERN.h"
58 #define PERL_IN_PERLIO_C
59 #include "perl.h"
60
61 #ifdef PERL_IMPLICIT_CONTEXT
62 #undef dSYS
63 #define dSYS dTHX
64 #endif
65
66 #include "XSUB.h"
67
68 #ifdef __Lynx__
69 /* Missing proto on LynxOS */
70 int mkstemp(char*);
71 #endif
72
73 #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     NULL,
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 (%d) does not match %s (%d)",
1271             "PerlIO layer function table size", tab->fsize,
1272             "size expected by this perl", sizeof(PerlIO_funcs) );
1273     }
1274     if (tab->size) {
1275         PerlIOl *l;
1276         if (tab->size < sizeof(PerlIOl)) {
1277             Perl_croak( aTHX_
1278                 "%s (%d) smaller than %s (%d)",
1279                 "PerlIO layer instance size", tab->size,
1280                 "size expected by this perl", 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) == -1) {
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     NULL,
1970     NULL,
1971     NULL,
1972     NULL,
1973     NULL,
1974     NULL,
1975     NULL,
1976     NULL,
1977     NULL,
1978     NULL,
1979     NULL,
1980     NULL,                       /* flush */
1981     NULL,                       /* fill */
1982     NULL,
1983     NULL,
1984     NULL,
1985     NULL,
1986     NULL,                       /* get_base */
1987     NULL,                       /* get_bufsiz */
1988     NULL,                       /* get_ptr */
1989     NULL,                       /* get_cnt */
1990     NULL,                       /* set_ptrcnt */
1991 };
1992
1993 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1994     sizeof(PerlIO_funcs),
1995     "bytes",
1996     0,
1997     PERLIO_K_DUMMY,
1998     PerlIOUtf8_pushed,
1999     NULL,
2000     NULL,
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 *
2025 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2026                IV n, const char *mode, int fd, int imode, int perm,
2027                PerlIO *old, int narg, SV **args)
2028 {
2029     PerlIO_funcs * const tab = PerlIO_default_btm();
2030     PERL_UNUSED_ARG(self);
2031     if (tab && tab->Open)
2032          return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2033                               old, narg, args);
2034     SETERRNO(EINVAL, LIB_INVARG);
2035     return NULL;
2036 }
2037
2038 PERLIO_FUNCS_DECL(PerlIO_raw) = {
2039     sizeof(PerlIO_funcs),
2040     "raw",
2041     0,
2042     PERLIO_K_DUMMY,
2043     PerlIORaw_pushed,
2044     PerlIOBase_popped,
2045     PerlIORaw_open,
2046     NULL,
2047     NULL,
2048     NULL,
2049     NULL,
2050     NULL,
2051     NULL,
2052     NULL,
2053     NULL,
2054     NULL,
2055     NULL,
2056     NULL,                       /* flush */
2057     NULL,                       /* fill */
2058     NULL,
2059     NULL,
2060     NULL,
2061     NULL,
2062     NULL,                       /* get_base */
2063     NULL,                       /* get_bufsiz */
2064     NULL,                       /* get_ptr */
2065     NULL,                       /* get_cnt */
2066     NULL,                       /* set_ptrcnt */
2067 };
2068 /*--------------------------------------------------------------------------------------*/
2069 /*--------------------------------------------------------------------------------------*/
2070 /*
2071  * "Methods" of the "base class"
2072  */
2073
2074 IV
2075 PerlIOBase_fileno(pTHX_ PerlIO *f)
2076 {
2077     return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2078 }
2079
2080 char *
2081 PerlIO_modestr(PerlIO * f, char *buf)
2082 {
2083     char *s = buf;
2084     if (PerlIOValid(f)) {
2085         const IV flags = PerlIOBase(f)->flags;
2086         if (flags & PERLIO_F_APPEND) {
2087             *s++ = 'a';
2088             if (flags & PERLIO_F_CANREAD) {
2089                 *s++ = '+';
2090             }
2091         }
2092         else if (flags & PERLIO_F_CANREAD) {
2093             *s++ = 'r';
2094             if (flags & PERLIO_F_CANWRITE)
2095                 *s++ = '+';
2096         }
2097         else if (flags & PERLIO_F_CANWRITE) {
2098             *s++ = 'w';
2099             if (flags & PERLIO_F_CANREAD) {
2100                 *s++ = '+';
2101             }
2102         }
2103 #ifdef PERLIO_USING_CRLF
2104         if (!(flags & PERLIO_F_CRLF))
2105             *s++ = 'b';
2106 #endif
2107     }
2108     *s = '\0';
2109     return buf;
2110 }
2111
2112
2113 IV
2114 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2115 {
2116     PerlIOl * const l = PerlIOBase(f);
2117     PERL_UNUSED_CONTEXT;
2118     PERL_UNUSED_ARG(arg);
2119
2120     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2121                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2122     if (tab && tab->Set_ptrcnt != NULL)
2123         l->flags |= PERLIO_F_FASTGETS;
2124     if (mode) {
2125         if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2126             mode++;
2127         switch (*mode++) {
2128         case 'r':
2129             l->flags |= PERLIO_F_CANREAD;
2130             break;
2131         case 'a':
2132             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2133             break;
2134         case 'w':
2135             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2136             break;
2137         default:
2138             SETERRNO(EINVAL, LIB_INVARG);
2139             return -1;
2140         }
2141         while (*mode) {
2142             switch (*mode++) {
2143             case '+':
2144                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2145                 break;
2146             case 'b':
2147                 l->flags &= ~PERLIO_F_CRLF;
2148                 break;
2149             case 't':
2150                 l->flags |= PERLIO_F_CRLF;
2151                 break;
2152             default:
2153                 SETERRNO(EINVAL, LIB_INVARG);
2154                 return -1;
2155             }
2156         }
2157     }
2158     else {
2159         if (l->next) {
2160             l->flags |= l->next->flags &
2161                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2162                  PERLIO_F_APPEND);
2163         }
2164     }
2165 #if 0
2166     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2167                  (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2168                  l->flags, PerlIO_modestr(f, temp));
2169 #endif
2170     return 0;
2171 }
2172
2173 IV
2174 PerlIOBase_popped(pTHX_ PerlIO *f)
2175 {
2176     PERL_UNUSED_CONTEXT;
2177     PERL_UNUSED_ARG(f);
2178     return 0;
2179 }
2180
2181 SSize_t
2182 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2183 {
2184     /*
2185      * Save the position as current head considers it
2186      */
2187     const Off_t old = PerlIO_tell(f);
2188     PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2189     PerlIOSelf(f, PerlIOBuf)->posn = old;
2190     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2191 }
2192
2193 SSize_t
2194 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2195 {
2196     STDCHAR *buf = (STDCHAR *) vbuf;
2197     if (f) {
2198         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2199             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2200             SETERRNO(EBADF, SS_IVCHAN);
2201             return 0;
2202         }
2203         while (count > 0) {
2204          get_cnt:
2205           {
2206             SSize_t avail = PerlIO_get_cnt(f);
2207             SSize_t take = 0;
2208             if (avail > 0)
2209                 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2210             if (take > 0) {
2211                 STDCHAR *ptr = PerlIO_get_ptr(f);
2212                 Copy(ptr, buf, take, STDCHAR);
2213                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2214                 count -= take;
2215                 buf += take;
2216                 if (avail == 0)         /* set_ptrcnt could have reset avail */
2217                     goto get_cnt;
2218             }
2219             if (count > 0 && avail <= 0) {
2220                 if (PerlIO_fill(f) != 0)
2221                     break;
2222             }
2223           }
2224         }
2225         return (buf - (STDCHAR *) vbuf);
2226     }
2227     return 0;
2228 }
2229
2230 IV
2231 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2232 {
2233     PERL_UNUSED_CONTEXT;
2234     PERL_UNUSED_ARG(f);
2235     return 0;
2236 }
2237
2238 IV
2239 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2240 {
2241     PERL_UNUSED_CONTEXT;
2242     PERL_UNUSED_ARG(f);
2243     return -1;
2244 }
2245
2246 IV
2247 PerlIOBase_close(pTHX_ PerlIO *f)
2248 {
2249     IV code = -1;
2250     if (PerlIOValid(f)) {
2251         PerlIO *n = PerlIONext(f);
2252         code = PerlIO_flush(f);
2253         PerlIOBase(f)->flags &=
2254            ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2255         while (PerlIOValid(n)) {
2256             const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2257             if (tab && tab->Close) {
2258                 if ((*tab->Close)(aTHX_ n) != 0)
2259                     code = -1;
2260                 break;
2261             }
2262             else {
2263                 PerlIOBase(n)->flags &=
2264                     ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2265             }
2266             n = PerlIONext(n);
2267         }
2268     }
2269     else {
2270         SETERRNO(EBADF, SS_IVCHAN);
2271     }
2272     return code;
2273 }
2274
2275 IV
2276 PerlIOBase_eof(pTHX_ PerlIO *f)
2277 {
2278     PERL_UNUSED_CONTEXT;
2279     if (PerlIOValid(f)) {
2280         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2281     }
2282     return 1;
2283 }
2284
2285 IV
2286 PerlIOBase_error(pTHX_ PerlIO *f)
2287 {
2288     PERL_UNUSED_CONTEXT;
2289     if (PerlIOValid(f)) {
2290         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2291     }
2292     return 1;
2293 }
2294
2295 void
2296 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2297 {
2298     if (PerlIOValid(f)) {
2299         PerlIO * const n = PerlIONext(f);
2300         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2301         if (PerlIOValid(n))
2302             PerlIO_clearerr(n);
2303     }
2304 }
2305
2306 void
2307 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2308 {
2309     PERL_UNUSED_CONTEXT;
2310     if (PerlIOValid(f)) {
2311         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2312     }
2313 }
2314
2315 SV *
2316 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2317 {
2318     if (!arg)
2319         return NULL;
2320 #ifdef sv_dup
2321     if (param) {
2322         arg = sv_dup(arg, param);
2323         SvREFCNT_inc_simple_void_NN(arg);
2324         return arg;
2325     }
2326     else {
2327         return newSVsv(arg);
2328     }
2329 #else
2330     PERL_UNUSED_ARG(param);
2331     return newSVsv(arg);
2332 #endif
2333 }
2334
2335 PerlIO *
2336 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2337 {
2338     PerlIO * const nexto = PerlIONext(o);
2339     if (PerlIOValid(nexto)) {
2340         const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2341         if (tab && tab->Dup)
2342             f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2343         else
2344             f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2345     }
2346     if (f) {
2347         PerlIO_funcs * const self = PerlIOBase(o)->tab;
2348         SV *arg = NULL;
2349         char buf[8];
2350         PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2351                      self ? self->name : "(Null)",
2352                      (void*)f, (void*)o, (void*)param);
2353         if (self && self->Getarg)
2354             arg = (*self->Getarg)(aTHX_ o, param, flags);
2355         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2356         if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2357             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2358         SvREFCNT_dec(arg);
2359     }
2360     return f;
2361 }
2362
2363 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2364
2365 /* Must be called with PL_perlio_mutex locked. */
2366 static void
2367 S_more_refcounted_fds(pTHX_ const int new_fd) {
2368     dVAR;
2369     const int old_max = PL_perlio_fd_refcnt_size;
2370     const int new_max = 16 + (new_fd & ~15);
2371     int *new_array;
2372
2373     PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2374                  old_max, new_fd, new_max);
2375
2376     if (new_fd < old_max) {
2377         return;
2378     }
2379
2380     assert (new_max > new_fd);
2381
2382     /* Use plain realloc() since we need this memory to be really
2383      * global and visible to all the interpreters and/or threads. */
2384     new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2385
2386     if (!new_array) {
2387 #ifdef USE_ITHREADS
2388         MUTEX_UNLOCK(&PL_perlio_mutex);
2389 #endif
2390         /* Can't use PerlIO to write as it allocates memory */
2391         PerlLIO_write(PerlIO_fileno(Perl_error_log),
2392                       PL_no_mem, strlen(PL_no_mem));
2393         my_exit(1);
2394     }
2395
2396     PL_perlio_fd_refcnt_size = new_max;
2397     PL_perlio_fd_refcnt = new_array;
2398
2399     PerlIO_debug("Zeroing %p, %d\n",
2400                  (void*)(new_array + old_max),
2401                  new_max - old_max);
2402
2403     Zero(new_array + old_max, new_max - old_max, int);
2404 }
2405
2406
2407 void
2408 PerlIO_init(pTHX)
2409 {
2410     /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2411     PERL_UNUSED_CONTEXT;
2412 }
2413
2414 void
2415 PerlIOUnix_refcnt_inc(int fd)
2416 {
2417     dTHX;
2418     if (fd >= 0) {
2419         dVAR;
2420
2421 #ifdef USE_ITHREADS
2422         MUTEX_LOCK(&PL_perlio_mutex);
2423 #endif
2424         if (fd >= PL_perlio_fd_refcnt_size)
2425             S_more_refcounted_fds(aTHX_ fd);
2426
2427         PL_perlio_fd_refcnt[fd]++;
2428         if (PL_perlio_fd_refcnt[fd] <= 0) {
2429             Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2430                        fd, PL_perlio_fd_refcnt[fd]);
2431         }
2432         PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2433                      fd, PL_perlio_fd_refcnt[fd]);
2434
2435 #ifdef USE_ITHREADS
2436         MUTEX_UNLOCK(&PL_perlio_mutex);
2437 #endif
2438     } else {
2439         Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2440     }
2441 }
2442
2443 int
2444 PerlIOUnix_refcnt_dec(int fd)
2445 {
2446     dTHX;
2447     int cnt = 0;
2448     if (fd >= 0) {
2449         dVAR;
2450 #ifdef USE_ITHREADS
2451         MUTEX_LOCK(&PL_perlio_mutex);
2452 #endif
2453         if (fd >= PL_perlio_fd_refcnt_size) {
2454             Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2455                        fd, PL_perlio_fd_refcnt_size);
2456         }
2457         if (PL_perlio_fd_refcnt[fd] <= 0) {
2458             Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2459                        fd, PL_perlio_fd_refcnt[fd]);
2460         }
2461         cnt = --PL_perlio_fd_refcnt[fd];
2462         PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2463 #ifdef USE_ITHREADS
2464         MUTEX_UNLOCK(&PL_perlio_mutex);
2465 #endif
2466     } else {
2467         Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2468     }
2469     return cnt;
2470 }
2471
2472 void
2473 PerlIO_cleanup(pTHX)
2474 {
2475     dVAR;
2476     int i;
2477 #ifdef USE_ITHREADS
2478     PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2479 #else
2480     PerlIO_debug("Cleanup layers\n");
2481 #endif
2482
2483     /* Raise STDIN..STDERR refcount so we don't close them */
2484     for (i=0; i < 3; i++)
2485         PerlIOUnix_refcnt_inc(i);
2486     PerlIO_cleantable(aTHX_ &PL_perlio);
2487     /* Restore STDIN..STDERR refcount */
2488     for (i=0; i < 3; i++)
2489         PerlIOUnix_refcnt_dec(i);
2490
2491     if (PL_known_layers) {
2492         PerlIO_list_free(aTHX_ PL_known_layers);
2493         PL_known_layers = NULL;
2494     }
2495     if (PL_def_layerlist) {
2496         PerlIO_list_free(aTHX_ PL_def_layerlist);
2497         PL_def_layerlist = NULL;
2498     }
2499 }
2500
2501 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2502 {
2503     dVAR;
2504 #if 0
2505 /* XXX we can't rely on an interpreter being present at this late stage,
2506    XXX so we can't use a function like PerlLIO_write that relies on one
2507    being present (at least in win32) :-(.
2508    Disable for now.
2509 */
2510 #ifdef DEBUGGING
2511     {
2512         /* By now all filehandles should have been closed, so any
2513          * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2514          * errors. */
2515 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2516 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2517         char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2518         int i;
2519         for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2520             if (PL_perlio_fd_refcnt[i]) {
2521                 const STRLEN len =
2522                     my_snprintf(buf, sizeof(buf),
2523                                 "PerlIO_teardown: fd %d refcnt=%d\n",
2524                                 i, PL_perlio_fd_refcnt[i]);
2525                 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2526             }
2527         }
2528     }
2529 #endif
2530 #endif
2531     /* Not bothering with PL_perlio_mutex since by now
2532      * all the interpreters are gone. */
2533     if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2534         && PL_perlio_fd_refcnt) {
2535         free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2536         PL_perlio_fd_refcnt = NULL;
2537         PL_perlio_fd_refcnt_size = 0;
2538     }
2539 }
2540
2541 /*--------------------------------------------------------------------------------------*/
2542 /*
2543  * Bottom-most level for UNIX-like case
2544  */
2545
2546 typedef struct {
2547     struct _PerlIO base;        /* The generic part */
2548     int fd;                     /* UNIX like file descriptor */
2549     int oflags;                 /* open/fcntl flags */
2550 } PerlIOUnix;
2551
2552 static void
2553 S_lockcnt_dec(pTHX_ const void* f)
2554 {
2555     PerlIO_lockcnt((PerlIO*)f)--;
2556 }
2557
2558
2559 /* call the signal handler, and if that handler happens to clear
2560  * this handle, free what we can and return true */
2561
2562 static bool
2563 S_perlio_async_run(pTHX_ PerlIO* f) {
2564     ENTER;
2565     SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2566     PerlIO_lockcnt(f)++;
2567     PERL_ASYNC_CHECK();
2568     if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
2569         return 0;
2570     /* we've just run some perl-level code that could have done
2571      * anything, including closing the file or clearing this layer.
2572      * If so, free any lower layers that have already been
2573      * cleared, then return an error. */
2574     while (PerlIOValid(f) &&
2575             (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2576     {
2577         const PerlIOl *l = *f;
2578         *f = l->next;
2579         Safefree(l);
2580     }
2581     return 1;
2582 }
2583
2584 int
2585 PerlIOUnix_oflags(const char *mode)
2586 {
2587     int oflags = -1;
2588     if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2589         mode++;
2590     switch (*mode) {
2591     case 'r':
2592         oflags = O_RDONLY;
2593         if (*++mode == '+') {
2594             oflags = O_RDWR;
2595             mode++;
2596         }
2597         break;
2598
2599     case 'w':
2600         oflags = O_CREAT | O_TRUNC;
2601         if (*++mode == '+') {
2602             oflags |= O_RDWR;
2603             mode++;
2604         }
2605         else
2606             oflags |= O_WRONLY;
2607         break;
2608
2609     case 'a':
2610         oflags = O_CREAT | O_APPEND;
2611         if (*++mode == '+') {
2612             oflags |= O_RDWR;
2613             mode++;
2614         }
2615         else
2616             oflags |= O_WRONLY;
2617         break;
2618     }
2619     if (*mode == 'b') {
2620         oflags |= O_BINARY;
2621         oflags &= ~O_TEXT;
2622         mode++;
2623     }
2624     else if (*mode == 't') {
2625         oflags |= O_TEXT;
2626         oflags &= ~O_BINARY;
2627         mode++;
2628     }
2629     /*
2630      * Always open in binary mode
2631      */
2632     oflags |= O_BINARY;
2633     if (*mode || oflags == -1) {
2634         SETERRNO(EINVAL, LIB_INVARG);
2635         oflags = -1;
2636     }
2637     return oflags;
2638 }
2639
2640 IV
2641 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2642 {
2643     PERL_UNUSED_CONTEXT;
2644     return PerlIOSelf(f, PerlIOUnix)->fd;
2645 }
2646
2647 static void
2648 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2649 {
2650     PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2651 #if defined(WIN32)
2652     Stat_t st;
2653     if (PerlLIO_fstat(fd, &st) == 0) {
2654         if (!S_ISREG(st.st_mode)) {
2655             PerlIO_debug("%d is not regular file\n",fd);
2656             PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2657         }
2658         else {
2659             PerlIO_debug("%d _is_ a regular file\n",fd);
2660         }
2661     }
2662 #endif
2663     s->fd = fd;
2664     s->oflags = imode;
2665     PerlIOUnix_refcnt_inc(fd);
2666     PERL_UNUSED_CONTEXT;
2667 }
2668
2669 IV
2670 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2671 {
2672     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2673     if (*PerlIONext(f)) {
2674         /* We never call down so do any pending stuff now */
2675         PerlIO_flush(PerlIONext(f));
2676         /*
2677          * XXX could (or should) we retrieve the oflags from the open file
2678          * handle rather than believing the "mode" we are passed in? XXX
2679          * Should the value on NULL mode be 0 or -1?
2680          */
2681         PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2682                          mode ? PerlIOUnix_oflags(mode) : -1);
2683     }
2684     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2685
2686     return code;
2687 }
2688
2689 IV
2690 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2691 {
2692     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2693     Off_t new_loc;
2694     PERL_UNUSED_CONTEXT;
2695     if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2696 #ifdef  ESPIPE
2697         SETERRNO(ESPIPE, LIB_INVARG);
2698 #else
2699         SETERRNO(EINVAL, LIB_INVARG);
2700 #endif
2701         return -1;
2702     }
2703     new_loc = PerlLIO_lseek(fd, offset, whence);
2704     if (new_loc == (Off_t) - 1)
2705         return -1;
2706     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2707     return  0;
2708 }
2709
2710 PerlIO *
2711 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2712                 IV n, const char *mode, int fd, int imode,
2713                 int perm, PerlIO *f, int narg, SV **args)
2714 {
2715     if (PerlIOValid(f)) {
2716         if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2717             (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2718     }
2719     if (narg > 0) {
2720         if (*mode == IoTYPE_NUMERIC)
2721             mode++;
2722         else {
2723             imode = PerlIOUnix_oflags(mode);
2724 #ifdef VMS
2725             perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2726 #else
2727             perm = 0666;
2728 #endif
2729         }
2730         if (imode != -1) {
2731             const char *path = SvPV_nolen_const(*args);
2732             fd = PerlLIO_open3(path, imode, perm);
2733         }
2734     }
2735     if (fd >= 0) {
2736         if (*mode == IoTYPE_IMPLICIT)
2737             mode++;
2738         if (!f) {
2739             f = PerlIO_allocate(aTHX);
2740         }
2741         if (!PerlIOValid(f)) {
2742             if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2743                 return NULL;
2744             }
2745         }
2746         PerlIOUnix_setfd(aTHX_ f, fd, imode);
2747         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2748         if (*mode == IoTYPE_APPEND)
2749             PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2750         return f;
2751     }
2752     else {
2753         if (f) {
2754             NOOP;
2755             /*
2756              * FIXME: pop layers ???
2757              */
2758         }
2759         return NULL;
2760     }
2761 }
2762
2763 PerlIO *
2764 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2765 {
2766     const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2767     int fd = os->fd;
2768     if (flags & PERLIO_DUP_FD) {
2769         fd = PerlLIO_dup(fd);
2770     }
2771     if (fd >= 0) {
2772         f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2773         if (f) {
2774             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2775             PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2776             return f;
2777         }
2778     }
2779     return NULL;
2780 }
2781
2782
2783 SSize_t
2784 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2785 {
2786     dVAR;
2787     int fd;
2788     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2789         return -1;
2790     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2791 #ifdef PERLIO_STD_SPECIAL
2792     if (fd == 0)
2793         return PERLIO_STD_IN(fd, vbuf, count);
2794 #endif
2795     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2796          PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2797         return 0;
2798     }
2799     while (1) {
2800         const SSize_t len = PerlLIO_read(fd, vbuf, count);
2801         if (len >= 0 || errno != EINTR) {
2802             if (len < 0) {
2803                 if (errno != EAGAIN) {
2804                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2805                 }
2806             }
2807             else if (len == 0 && count != 0) {
2808                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2809                 SETERRNO(0,0);
2810             }
2811             return len;
2812         }
2813         /* EINTR */
2814         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2815             return -1;
2816     }
2817     /*NOTREACHED*/
2818 }
2819
2820 SSize_t
2821 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2822 {
2823     dVAR;
2824     int fd;
2825     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2826         return -1;
2827     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2828 #ifdef PERLIO_STD_SPECIAL
2829     if (fd == 1 || fd == 2)
2830         return PERLIO_STD_OUT(fd, vbuf, count);
2831 #endif
2832     while (1) {
2833         const SSize_t len = PerlLIO_write(fd, vbuf, count);
2834         if (len >= 0 || errno != EINTR) {
2835             if (len < 0) {
2836                 if (errno != EAGAIN) {
2837                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2838                 }
2839             }
2840             return len;
2841         }
2842         /* EINTR */
2843         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2844             return -1;
2845     }
2846     /*NOTREACHED*/
2847 }
2848
2849 Off_t
2850 PerlIOUnix_tell(pTHX_ PerlIO *f)
2851 {
2852     PERL_UNUSED_CONTEXT;
2853
2854     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2855 }
2856
2857
2858 IV
2859 PerlIOUnix_close(pTHX_ PerlIO *f)
2860 {
2861     dVAR;
2862     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2863     int code = 0;
2864     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2865         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2866             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2867             return 0;
2868         }
2869     }
2870     else {
2871         SETERRNO(EBADF,SS_IVCHAN);
2872         return -1;
2873     }
2874     while (PerlLIO_close(fd) != 0) {
2875         if (errno != EINTR) {
2876             code = -1;
2877             break;
2878         }
2879         /* EINTR */
2880         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2881             return -1;
2882     }
2883     if (code == 0) {
2884         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2885     }
2886     return code;
2887 }
2888
2889 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2890     sizeof(PerlIO_funcs),
2891     "unix",
2892     sizeof(PerlIOUnix),
2893     PERLIO_K_RAW,
2894     PerlIOUnix_pushed,
2895     PerlIOBase_popped,
2896     PerlIOUnix_open,
2897     PerlIOBase_binmode,         /* binmode */
2898     NULL,
2899     PerlIOUnix_fileno,
2900     PerlIOUnix_dup,
2901     PerlIOUnix_read,
2902     PerlIOBase_unread,
2903     PerlIOUnix_write,
2904     PerlIOUnix_seek,
2905     PerlIOUnix_tell,
2906     PerlIOUnix_close,
2907     PerlIOBase_noop_ok,         /* flush */
2908     PerlIOBase_noop_fail,       /* fill */
2909     PerlIOBase_eof,
2910     PerlIOBase_error,
2911     PerlIOBase_clearerr,
2912     PerlIOBase_setlinebuf,
2913     NULL,                       /* get_base */
2914     NULL,                       /* get_bufsiz */
2915     NULL,                       /* get_ptr */
2916     NULL,                       /* get_cnt */
2917     NULL,                       /* set_ptrcnt */
2918 };
2919
2920 /*--------------------------------------------------------------------------------------*/
2921 /*
2922  * stdio as a layer
2923  */
2924
2925 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2926 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2927    broken by the last second glibc 2.3 fix
2928  */
2929 #define STDIO_BUFFER_WRITABLE
2930 #endif
2931
2932
2933 typedef struct {
2934     struct _PerlIO base;
2935     FILE *stdio;                /* The stream */
2936 } PerlIOStdio;
2937
2938 IV
2939 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2940 {
2941     PERL_UNUSED_CONTEXT;
2942
2943     if (PerlIOValid(f)) {
2944         FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2945         if (s)
2946             return PerlSIO_fileno(s);
2947     }
2948     errno = EBADF;
2949     return -1;
2950 }
2951
2952 char *
2953 PerlIOStdio_mode(const char *mode, char *tmode)
2954 {
2955     char * const ret = tmode;
2956     if (mode) {
2957         while (*mode) {
2958             *tmode++ = *mode++;
2959         }
2960     }
2961 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2962     *tmode++ = 'b';
2963 #endif
2964     *tmode = '\0';
2965     return ret;
2966 }
2967
2968 IV
2969 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2970 {
2971     PerlIO *n;
2972     if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2973         PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2974         if (toptab == tab) {
2975             /* Top is already stdio - pop self (duplicate) and use original */
2976             PerlIO_pop(aTHX_ f);
2977             return 0;
2978         } else {
2979             const int fd = PerlIO_fileno(n);
2980             char tmode[8];
2981             FILE *stdio;
2982             if (fd >= 0 && (stdio  = PerlSIO_fdopen(fd,
2983                             mode = PerlIOStdio_mode(mode, tmode)))) {
2984                 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2985                 /* We never call down so do any pending stuff now */
2986                 PerlIO_flush(PerlIONext(f));
2987             }
2988             else {
2989                 return -1;
2990             }
2991         }
2992     }
2993     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2994 }
2995
2996
2997 PerlIO *
2998 PerlIO_importFILE(FILE *stdio, const char *mode)
2999 {
3000     dTHX;
3001     PerlIO *f = NULL;
3002     if (stdio) {
3003         PerlIOStdio *s;
3004         if (!mode || !*mode) {
3005             /* We need to probe to see how we can open the stream
3006                so start with read/write and then try write and read
3007                we dup() so that we can fclose without loosing the fd.
3008
3009                Note that the errno value set by a failing fdopen
3010                varies between stdio implementations.
3011              */
3012             const int fd = PerlLIO_dup(fileno(stdio));
3013             FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
3014             if (!f2) {
3015                 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3016             }
3017             if (!f2) {
3018                 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3019             }
3020             if (!f2) {
3021                 /* Don't seem to be able to open */
3022                 PerlLIO_close(fd);
3023                 return f;
3024             }
3025             fclose(f2);
3026         }
3027         if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3028             s = PerlIOSelf(f, PerlIOStdio);
3029             s->stdio = stdio;
3030             PerlIOUnix_refcnt_inc(fileno(stdio));
3031         }
3032     }
3033     return f;
3034 }
3035
3036 PerlIO *
3037 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3038                  IV n, const char *mode, int fd, int imode,
3039                  int perm, PerlIO *f, int narg, SV **args)
3040 {
3041     char tmode[8];
3042     if (PerlIOValid(f)) {
3043         const char * const path = SvPV_nolen_const(*args);
3044         PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3045         FILE *stdio;
3046         PerlIOUnix_refcnt_dec(fileno(s->stdio));
3047         stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3048                             s->stdio);
3049         if (!s->stdio)
3050             return NULL;
3051         s->stdio = stdio;
3052         PerlIOUnix_refcnt_inc(fileno(s->stdio));
3053         return f;
3054     }
3055     else {
3056         if (narg > 0) {
3057             const char * const path = SvPV_nolen_const(*args);
3058             if (*mode == IoTYPE_NUMERIC) {
3059                 mode++;
3060                 fd = PerlLIO_open3(path, imode, perm);
3061             }
3062             else {
3063                 FILE *stdio;
3064                 bool appended = FALSE;
3065 #ifdef __CYGWIN__
3066                 /* Cygwin wants its 'b' early. */
3067                 appended = TRUE;
3068                 mode = PerlIOStdio_mode(mode, tmode);
3069 #endif
3070                 stdio = PerlSIO_fopen(path, mode);
3071                 if (stdio) {
3072                     if (!f) {
3073                         f = PerlIO_allocate(aTHX);
3074                     }
3075                     if (!appended)
3076                         mode = PerlIOStdio_mode(mode, tmode);
3077                     f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3078                     if (f) {
3079                         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3080                         PerlIOUnix_refcnt_inc(fileno(stdio));
3081                     } else {
3082                         PerlSIO_fclose(stdio);
3083                     }
3084                     return f;
3085                 }
3086                 else {
3087                     return NULL;
3088                 }
3089             }
3090         }
3091         if (fd >= 0) {
3092             FILE *stdio = NULL;
3093             int init = 0;
3094             if (*mode == IoTYPE_IMPLICIT) {
3095                 init = 1;
3096                 mode++;
3097             }
3098             if (init) {
3099                 switch (fd) {
3100                 case 0:
3101                     stdio = PerlSIO_stdin;
3102                     break;
3103                 case 1:
3104                     stdio = PerlSIO_stdout;
3105                     break;
3106                 case 2:
3107                     stdio = PerlSIO_stderr;
3108                     break;
3109                 }
3110             }
3111             else {
3112                 stdio = PerlSIO_fdopen(fd, mode =
3113                                        PerlIOStdio_mode(mode, tmode));
3114             }
3115             if (stdio) {
3116                 if (!f) {
3117                     f = PerlIO_allocate(aTHX);
3118                 }
3119                 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3120                     PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3121                     PerlIOUnix_refcnt_inc(fileno(stdio));
3122                 }
3123                 return f;
3124             }
3125         }
3126     }
3127     return NULL;
3128 }
3129
3130 PerlIO *
3131 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3132 {
3133     /* This assumes no layers underneath - which is what
3134        happens, but is not how I remember it. NI-S 2001/10/16
3135      */
3136     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3137         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3138         const int fd = fileno(stdio);
3139         char mode[8];
3140         if (flags & PERLIO_DUP_FD) {
3141             const int dfd = PerlLIO_dup(fileno(stdio));
3142             if (dfd >= 0) {
3143                 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3144                 goto set_this;
3145             }
3146             else {
3147                 NOOP;
3148                 /* FIXME: To avoid messy error recovery if dup fails
3149                    re-use the existing stdio as though flag was not set
3150                  */
3151             }
3152         }
3153         stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3154     set_this:
3155         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3156         if(stdio) {
3157             PerlIOUnix_refcnt_inc(fileno(stdio));
3158         }
3159     }
3160     return f;
3161 }
3162
3163 static int
3164 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3165 {
3166     PERL_UNUSED_CONTEXT;
3167
3168     /* XXX this could use PerlIO_canset_fileno() and
3169      * PerlIO_set_fileno() support from Configure
3170      */
3171 #  if defined(__UCLIBC__)
3172     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3173     f->__filedes = -1;
3174     return 1;
3175 #  elif defined(__GLIBC__)
3176     /* There may be a better way for GLIBC:
3177         - libio.h defines a flag to not close() on cleanup
3178      */ 
3179     f->_fileno = -1;
3180     return 1;
3181 #  elif defined(__sun__)
3182     PERL_UNUSED_ARG(f);
3183     return 0;
3184 #  elif defined(__hpux)
3185     f->__fileH = 0xff;
3186     f->__fileL = 0xff;
3187     return 1;
3188    /* Next one ->_file seems to be a reasonable fallback, i.e. if
3189       your platform does not have special entry try this one.
3190       [For OSF only have confirmation for Tru64 (alpha)
3191       but assume other OSFs will be similar.]
3192     */
3193 #  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3194     f->_file = -1;
3195     return 1;
3196 #  elif defined(__FreeBSD__)
3197     /* There may be a better way on FreeBSD:
3198         - we could insert a dummy func in the _close function entry
3199         f->_close = (int (*)(void *)) dummy_close;
3200      */
3201     f->_file = -1;
3202     return 1;
3203 #  elif defined(__OpenBSD__)
3204     /* There may be a better way on OpenBSD:
3205         - we could insert a dummy func in the _close function entry
3206         f->_close = (int (*)(void *)) dummy_close;
3207      */
3208     f->_file = -1;
3209     return 1;
3210 #  elif defined(__EMX__)
3211     /* f->_flags &= ~_IOOPEN; */        /* Will leak stream->_buffer */
3212     f->_handle = -1;
3213     return 1;
3214 #  elif defined(__CYGWIN__)
3215     /* There may be a better way on CYGWIN:
3216         - we could insert a dummy func in the _close function entry
3217         f->_close = (int (*)(void *)) dummy_close;
3218      */
3219     f->_file = -1;
3220     return 1;
3221 #  elif defined(WIN32)
3222 #    if defined(__BORLANDC__)
3223     f->fd = PerlLIO_dup(fileno(f));
3224 #    elif defined(UNDER_CE)
3225     /* WIN_CE does not have access to FILE internals, it hardly has FILE
3226        structure at all
3227      */
3228 #    else
3229     f->_file = -1;
3230 #    endif
3231     return 1;
3232 #  else
3233 #if 0
3234     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3235        (which isn't thread safe) instead
3236      */
3237 #    error "Don't know how to set FILE.fileno on your platform"
3238 #endif
3239     PERL_UNUSED_ARG(f);
3240     return 0;
3241 #  endif
3242 }
3243
3244 IV
3245 PerlIOStdio_close(pTHX_ PerlIO *f)
3246 {
3247     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3248     if (!stdio) {
3249         errno = EBADF;
3250         return -1;
3251     }
3252     else {
3253         const int fd = fileno(stdio);
3254         int invalidate = 0;
3255         IV result = 0;
3256         int dupfd = -1;
3257         dSAVEDERRNO;
3258 #ifdef USE_ITHREADS
3259         dVAR;
3260 #endif
3261 #ifdef SOCKS5_VERSION_NAME
3262         /* Socks lib overrides close() but stdio isn't linked to
3263            that library (though we are) - so we must call close()
3264            on sockets on stdio's behalf.
3265          */
3266         int optval;
3267         Sock_size_t optlen = sizeof(int);
3268         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3269             invalidate = 1;
3270 #endif
3271         /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3272            that a subsequent fileno() on it returns -1. Don't want to croak()
3273            from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3274            trying to close an already closed handle which somehow it still has
3275            a reference to. (via.xs, I'm looking at you).  */
3276         if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3277             /* File descriptor still in use */
3278             invalidate = 1;
3279         }
3280         if (invalidate) {
3281             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3282             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3283                 return 0;
3284             if (stdio == stdout || stdio == stderr)
3285                 return PerlIO_flush(f);
3286             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3287                Use Sarathy's trick from maint-5.6 to invalidate the
3288                fileno slot of the FILE *
3289             */
3290             result = PerlIO_flush(f);
3291             SAVE_ERRNO;
3292             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3293             if (!invalidate) {
3294 #ifdef USE_ITHREADS
3295                 MUTEX_LOCK(&PL_perlio_mutex);
3296                 /* Right. We need a mutex here because for a brief while we
3297                    will have the situation that fd is actually closed. Hence if
3298                    a second thread were to get into this block, its dup() would
3299                    likely return our fd as its dupfd. (after all, it is closed)
3300                    Then if we get to the dup2() first, we blat the fd back
3301                    (messing up its temporary as a side effect) only for it to
3302                    then close its dupfd (== our fd) in its close(dupfd) */
3303
3304                 /* There is, of course, a race condition, that any other thread
3305                    trying to input/output/whatever on this fd will be stuffed
3306                    for the duration of this little manoeuvrer. Perhaps we
3307                    should hold an IO mutex for the duration of every IO
3308                    operation if we know that invalidate doesn't work on this
3309                    platform, but that would suck, and could kill performance.
3310
3311                    Except that correctness trumps speed.
3312                    Advice from klortho #11912. */
3313 #endif
3314                 dupfd = PerlLIO_dup(fd);
3315 #ifdef USE_ITHREADS
3316                 if (dupfd < 0) {
3317                     MUTEX_UNLOCK(&PL_perlio_mutex);
3318                     /* Oh cXap. This isn't going to go well. Not sure if we can
3319                        recover from here, or if closing this particular FILE *
3320                        is a good idea now.  */
3321                 }
3322 #endif
3323             }
3324         } else {
3325             SAVE_ERRNO;   /* This is here only to silence compiler warnings */
3326         }
3327         result = PerlSIO_fclose(stdio);
3328         /* We treat error from stdio as success if we invalidated
3329            errno may NOT be expected EBADF
3330          */
3331         if (invalidate && result != 0) {
3332             RESTORE_ERRNO;
3333             result = 0;
3334         }
3335 #ifdef SOCKS5_VERSION_NAME
3336         /* in SOCKS' case, let close() determine return value */
3337         result = close(fd);
3338 #endif
3339         if (dupfd >= 0) {
3340             PerlLIO_dup2(dupfd,fd);
3341             PerlLIO_close(dupfd);
3342 #ifdef USE_ITHREADS
3343             MUTEX_UNLOCK(&PL_perlio_mutex);
3344 #endif
3345         }
3346         return result;
3347     }
3348 }
3349
3350 SSize_t
3351 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3352 {
3353     dVAR;
3354     FILE * s;
3355     SSize_t got = 0;
3356     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3357         return -1;
3358     s = PerlIOSelf(f, PerlIOStdio)->stdio;
3359     for (;;) {
3360         if (count == 1) {
3361             STDCHAR *buf = (STDCHAR *) vbuf;
3362             /*
3363              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3364              * stdio does not do that for fread()
3365              */
3366             const int ch = PerlSIO_fgetc(s);
3367             if (ch != EOF) {
3368                 *buf = ch;
3369                 got = 1;
3370             }
3371         }
3372         else
3373             got = PerlSIO_fread(vbuf, 1, count, s);
3374         if (got == 0 && PerlSIO_ferror(s))
3375             got = -1;
3376         if (got >= 0 || errno != EINTR)
3377             break;
3378         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3379             return -1;
3380         SETERRNO(0,0);  /* just in case */
3381     }
3382     return got;
3383 }
3384
3385 SSize_t
3386 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3387 {
3388     SSize_t unread = 0;
3389     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3390
3391 #ifdef STDIO_BUFFER_WRITABLE
3392     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3393         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3394         STDCHAR *base = PerlIO_get_base(f);
3395         SSize_t cnt   = PerlIO_get_cnt(f);
3396         STDCHAR *ptr  = PerlIO_get_ptr(f);
3397         SSize_t avail = ptr - base;
3398         if (avail > 0) {
3399             if (avail > count) {
3400                 avail = count;
3401             }
3402             ptr -= avail;
3403             Move(buf-avail,ptr,avail,STDCHAR);
3404             count -= avail;
3405             unread += avail;
3406             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3407             if (PerlSIO_feof(s) && unread >= 0)
3408                 PerlSIO_clearerr(s);
3409         }
3410     }
3411     else
3412 #endif
3413     if (PerlIO_has_cntptr(f)) {
3414         /* We can get pointer to buffer but not its base
3415            Do ungetc() but check chars are ending up in the
3416            buffer
3417          */
3418         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3419         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3420         while (count > 0) {
3421             const int ch = *--buf & 0xFF;
3422             if (ungetc(ch,s) != ch) {
3423                 /* ungetc did not work */
3424                 break;
3425             }
3426             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3427                 /* Did not change pointer as expected */
3428                 fgetc(s);  /* get char back again */
3429                 break;
3430             }
3431             /* It worked ! */
3432             count--;
3433             unread++;
3434         }
3435     }
3436
3437     if (count > 0) {
3438         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3439     }
3440     return unread;
3441 }
3442
3443 SSize_t
3444 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3445 {
3446     dVAR;
3447     SSize_t got;
3448     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3449         return -1;
3450     for (;;) {
3451         got = PerlSIO_fwrite(vbuf, 1, count,
3452                               PerlIOSelf(f, PerlIOStdio)->stdio);
3453         if (got >= 0 || errno != EINTR)
3454             break;
3455         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3456             return -1;
3457         SETERRNO(0,0);  /* just in case */
3458     }
3459     return got;
3460 }
3461
3462 IV
3463 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3464 {
3465     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3466     PERL_UNUSED_CONTEXT;
3467
3468     return PerlSIO_fseek(stdio, offset, whence);
3469 }
3470
3471 Off_t
3472 PerlIOStdio_tell(pTHX_ PerlIO *f)
3473 {
3474     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3475     PERL_UNUSED_CONTEXT;
3476
3477     return PerlSIO_ftell(stdio);
3478 }
3479
3480 IV
3481 PerlIOStdio_flush(pTHX_ PerlIO *f)
3482 {
3483     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3484     PERL_UNUSED_CONTEXT;
3485
3486     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3487         return PerlSIO_fflush(stdio);
3488     }
3489     else {
3490         NOOP;
3491 #if 0
3492         /*
3493          * FIXME: This discards ungetc() and pre-read stuff which is not
3494          * right if this is just a "sync" from a layer above Suspect right
3495          * design is to do _this_ but not have layer above flush this
3496          * layer read-to-read
3497          */
3498         /*
3499          * Not writeable - sync by attempting a seek
3500          */
3501         dSAVE_ERRNO;
3502         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3503             RESTORE_ERRNO;
3504 #endif
3505     }
3506     return 0;
3507 }
3508
3509 IV
3510 PerlIOStdio_eof(pTHX_ PerlIO *f)
3511 {
3512     PERL_UNUSED_CONTEXT;
3513
3514     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3515 }
3516
3517 IV
3518 PerlIOStdio_error(pTHX_ PerlIO *f)
3519 {
3520     PERL_UNUSED_CONTEXT;
3521
3522     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3523 }
3524
3525 void
3526 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3527 {
3528     PERL_UNUSED_CONTEXT;
3529
3530     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3531 }
3532
3533 void
3534 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3535 {
3536     PERL_UNUSED_CONTEXT;
3537
3538 #ifdef HAS_SETLINEBUF
3539     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3540 #else
3541     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3542 #endif
3543 }
3544
3545 #ifdef FILE_base
3546 STDCHAR *
3547 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3548 {
3549     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3550     return (STDCHAR*)PerlSIO_get_base(stdio);
3551 }
3552
3553 Size_t
3554 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3555 {
3556     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3557     return PerlSIO_get_bufsiz(stdio);
3558 }
3559 #endif
3560
3561 #ifdef USE_STDIO_PTR
3562 STDCHAR *
3563 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3564 {
3565     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3566     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3567 }
3568
3569 SSize_t
3570 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3571 {
3572     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3573     return PerlSIO_get_cnt(stdio);
3574 }
3575
3576 void
3577 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3578 {
3579     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3580     if (ptr != NULL) {
3581 #ifdef STDIO_PTR_LVALUE
3582         PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3583 #ifdef STDIO_PTR_LVAL_SETS_CNT
3584         assert(PerlSIO_get_cnt(stdio) == (cnt));
3585 #endif
3586 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3587         /*
3588          * Setting ptr _does_ change cnt - we are done
3589          */
3590         return;
3591 #endif
3592 #else                           /* STDIO_PTR_LVALUE */
3593         PerlProc_abort();
3594 #endif                          /* STDIO_PTR_LVALUE */
3595     }
3596     /*
3597      * Now (or only) set cnt
3598      */
3599 #ifdef STDIO_CNT_LVALUE
3600     PerlSIO_set_cnt(stdio, cnt);
3601 #else                           /* STDIO_CNT_LVALUE */
3602 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3603     PerlSIO_set_ptr(stdio,
3604                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3605                                               cnt));
3606 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3607     PerlProc_abort();
3608 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3609 #endif                          /* STDIO_CNT_LVALUE */
3610 }
3611
3612
3613 #endif
3614
3615 IV
3616 PerlIOStdio_fill(pTHX_ PerlIO *f)
3617 {
3618     FILE * stdio;
3619     int c;
3620     PERL_UNUSED_CONTEXT;
3621     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3622         return -1;
3623     stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3624
3625     /*
3626      * fflush()ing read-only streams can cause trouble on some stdio-s
3627      */
3628     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3629         if (PerlSIO_fflush(stdio) != 0)
3630             return EOF;
3631     }
3632     for (;;) {
3633         c = PerlSIO_fgetc(stdio);
3634         if (c != EOF)
3635             break;
3636         if (! PerlSIO_ferror(stdio) || errno != EINTR)
3637             return EOF;
3638         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3639             return -1;
3640         SETERRNO(0,0);
3641     }
3642
3643 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3644
3645 #ifdef STDIO_BUFFER_WRITABLE
3646     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3647         /* Fake ungetc() to the real buffer in case system's ungetc
3648            goes elsewhere
3649          */
3650         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3651         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3652         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3653         if (ptr == base+1) {
3654             *--ptr = (STDCHAR) c;
3655             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3656             if (PerlSIO_feof(stdio))
3657                 PerlSIO_clearerr(stdio);
3658             return 0;
3659         }
3660     }
3661     else
3662 #endif
3663     if (PerlIO_has_cntptr(f)) {
3664         STDCHAR ch = c;
3665         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3666             return 0;
3667         }
3668     }
3669 #endif
3670
3671 #if defined(VMS)
3672     /* An ungetc()d char is handled separately from the regular
3673      * buffer, so we stuff it in the buffer ourselves.
3674      * Should never get called as should hit code above
3675      */
3676     *(--((*stdio)->_ptr)) = (unsigned char) c;
3677     (*stdio)->_cnt++;
3678 #else
3679     /* If buffer snoop scheme above fails fall back to
3680        using ungetc().
3681      */
3682     if (PerlSIO_ungetc(c, stdio) != c)
3683         return EOF;
3684 #endif
3685     return 0;
3686 }
3687
3688
3689
3690 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3691     sizeof(PerlIO_funcs),
3692     "stdio",
3693     sizeof(PerlIOStdio),
3694     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3695     PerlIOStdio_pushed,
3696     PerlIOBase_popped,
3697     PerlIOStdio_open,
3698     PerlIOBase_binmode,         /* binmode */
3699     NULL,
3700     PerlIOStdio_fileno,
3701     PerlIOStdio_dup,
3702     PerlIOStdio_read,
3703     PerlIOStdio_unread,
3704     PerlIOStdio_write,
3705     PerlIOStdio_seek,
3706     PerlIOStdio_tell,
3707     PerlIOStdio_close,
3708     PerlIOStdio_flush,
3709     PerlIOStdio_fill,
3710     PerlIOStdio_eof,
3711     PerlIOStdio_error,
3712     PerlIOStdio_clearerr,
3713     PerlIOStdio_setlinebuf,
3714 #ifdef FILE_base
3715     PerlIOStdio_get_base,
3716     PerlIOStdio_get_bufsiz,
3717 #else
3718     NULL,
3719     NULL,
3720 #endif
3721 #ifdef USE_STDIO_PTR
3722     PerlIOStdio_get_ptr,
3723     PerlIOStdio_get_cnt,
3724 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3725     PerlIOStdio_set_ptrcnt,
3726 #   else
3727     NULL,
3728 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3729 #else
3730     NULL,
3731     NULL,
3732     NULL,
3733 #endif /* USE_STDIO_PTR */
3734 };
3735
3736 /* Note that calls to PerlIO_exportFILE() are reversed using
3737  * PerlIO_releaseFILE(), not importFILE. */
3738 FILE *
3739 PerlIO_exportFILE(PerlIO * f, const char *mode)
3740 {
3741     dTHX;
3742     FILE *stdio = NULL;
3743     if (PerlIOValid(f)) {
3744         char buf[8];
3745         PerlIO_flush(f);
3746         if (!mode || !*mode) {
3747             mode = PerlIO_modestr(f, buf);
3748         }
3749         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3750         if (stdio) {
3751             PerlIOl *l = *f;
3752             PerlIO *f2;
3753             /* De-link any lower layers so new :stdio sticks */
3754             *f = NULL;
3755             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3756                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3757                 s->stdio = stdio;
3758                 PerlIOUnix_refcnt_inc(fileno(stdio));
3759                 /* Link previous lower layers under new one */
3760                 *PerlIONext(f) = l;
3761             }
3762             else {
3763                 /* restore layers list */
3764                 *f = l;
3765             }
3766         }
3767     }
3768     return stdio;
3769 }
3770
3771
3772 FILE *
3773 PerlIO_findFILE(PerlIO *f)
3774 {
3775     PerlIOl *l = *f;
3776     FILE *stdio;
3777     while (l) {
3778         if (l->tab == &PerlIO_stdio) {
3779             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3780             return s->stdio;
3781         }
3782         l = *PerlIONext(&l);
3783     }
3784     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3785     /* However, we're not really exporting a FILE * to someone else (who
3786        becomes responsible for closing it, or calling PerlIO_releaseFILE())
3787        So we need to undo its reference count increase on the underlying file
3788        descriptor. We have to do this, because if the loop above returns you
3789        the FILE *, then *it* didn't increase any reference count. So there's
3790        only one way to be consistent. */
3791     stdio = PerlIO_exportFILE(f, NULL);
3792     if (stdio) {
3793         const int fd = fileno(stdio);
3794         if (fd >= 0)
3795             PerlIOUnix_refcnt_dec(fd);
3796     }
3797     return stdio;
3798 }
3799
3800 /* Use this to reverse PerlIO_exportFILE calls. */
3801 void
3802 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3803 {
3804     dVAR;
3805     PerlIOl *l;
3806     while ((l = *p)) {
3807         if (l->tab == &PerlIO_stdio) {
3808             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3809             if (s->stdio == f) {
3810                 dTHX;
3811                 const int fd = fileno(f);
3812                 if (fd >= 0)
3813                     PerlIOUnix_refcnt_dec(fd);
3814                 PerlIO_pop(aTHX_ p);
3815                 return;
3816             }
3817         }
3818         p = PerlIONext(p);
3819     }
3820     return;
3821 }
3822
3823 /*--------------------------------------------------------------------------------------*/
3824 /*
3825  * perlio buffer layer
3826  */
3827
3828 IV
3829 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3830 {
3831     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3832     const int fd = PerlIO_fileno(f);
3833     if (fd >= 0 && PerlLIO_isatty(fd)) {
3834         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3835     }
3836     if (*PerlIONext(f)) {
3837         const Off_t posn = PerlIO_tell(PerlIONext(f));
3838         if (posn != (Off_t) - 1) {
3839             b->posn = posn;
3840         }
3841     }
3842     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3843 }
3844
3845 PerlIO *
3846 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3847                IV n, const char *mode, int fd, int imode, int perm,
3848                PerlIO *f, int narg, SV **args)
3849 {
3850     if (PerlIOValid(f)) {
3851         PerlIO *next = PerlIONext(f);
3852         PerlIO_funcs *tab =
3853              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3854         if (tab && tab->Open)
3855              next =
3856                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3857                                next, narg, args);
3858         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3859             return NULL;
3860         }
3861     }
3862     else {
3863         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3864         int init = 0;
3865         if (*mode == IoTYPE_IMPLICIT) {
3866             init = 1;
3867             /*
3868              * mode++;
3869              */
3870         }
3871         if (tab && tab->Open)
3872              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3873                               f, narg, args);
3874         else
3875              SETERRNO(EINVAL, LIB_INVARG);
3876         if (f) {
3877             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3878                 /*
3879                  * if push fails during open, open fails. close will pop us.
3880                  */
3881                 PerlIO_close (f);
3882                 return NULL;
3883             } else {
3884                 fd = PerlIO_fileno(f);
3885                 if (init && fd == 2) {
3886                     /*
3887                      * Initial stderr is unbuffered
3888                      */
3889                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3890                 }
3891 #ifdef PERLIO_USING_CRLF
3892 #  ifdef PERLIO_IS_BINMODE_FD
3893                 if (PERLIO_IS_BINMODE_FD(fd))
3894                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3895                 else
3896 #  endif
3897                 /*
3898                  * do something about failing setmode()? --jhi
3899                  */
3900                 PerlLIO_setmode(fd, O_BINARY);
3901 #endif
3902 #ifdef VMS
3903 #include <rms.h>
3904                 /* Enable line buffering with record-oriented regular files
3905                  * so we don't introduce an extraneous record boundary when
3906                  * the buffer fills up.
3907                  */
3908                 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3909                     Stat_t st;
3910                     if (PerlLIO_fstat(fd, &st) == 0
3911                         && S_ISREG(st.st_mode)
3912                         && (st.st_fab_rfm == FAB$C_VAR 
3913                             || st.st_fab_rfm == FAB$C_VFC)) {
3914                         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3915                     }
3916                 }
3917 #endif
3918             }
3919         }
3920     }
3921     return f;
3922 }
3923
3924 /*
3925  * This "flush" is akin to sfio's sync in that it handles files in either
3926  * read or write state.  For write state, we put the postponed data through
3927  * the next layers.  For read state, we seek() the next layers to the
3928  * offset given by current position in the buffer, and discard the buffer
3929  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3930  * in any case?).  Then the pass the stick further in chain.
3931  */
3932 IV
3933 PerlIOBuf_flush(pTHX_ PerlIO *f)
3934 {
3935     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3936     int code = 0;
3937     PerlIO *n = PerlIONext(f);
3938     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3939         /*
3940          * write() the buffer
3941          */
3942         const STDCHAR *buf = b->buf;
3943         const STDCHAR *p = buf;
3944         while (p < b->ptr) {
3945             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3946             if (count > 0) {
3947                 p += count;
3948             }
3949             else if (count < 0 || PerlIO_error(n)) {
3950                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3951                 code = -1;
3952                 break;
3953             }
3954         }
3955         b->posn += (p - buf);
3956     }
3957     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3958         STDCHAR *buf = PerlIO_get_base(f);
3959         /*
3960          * Note position change
3961          */
3962         b->posn += (b->ptr - buf);
3963         if (b->ptr < b->end) {
3964             /* We did not consume all of it - try and seek downstream to
3965                our logical position
3966              */
3967             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3968                 /* Reload n as some layers may pop themselves on seek */
3969                 b->posn = PerlIO_tell(n = PerlIONext(f));
3970             }
3971             else {
3972                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3973                    data is lost for good - so return saying "ok" having undone
3974                    the position adjust
3975                  */
3976                 b->posn -= (b->ptr - buf);
3977                 return code;
3978             }
3979         }
3980     }
3981     b->ptr = b->end = b->buf;
3982     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3983     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3984     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3985         code = -1;
3986     return code;
3987 }
3988
3989 /* This discards the content of the buffer after b->ptr, and rereads
3990  * the buffer from the position off in the layer downstream; here off
3991  * is at offset corresponding to b->ptr - b->buf.
3992  */
3993 IV
3994 PerlIOBuf_fill(pTHX_ PerlIO *f)
3995 {
3996     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3997     PerlIO *n = PerlIONext(f);
3998     SSize_t avail;
3999     /*
4000      * Down-stream flush is defined not to loose read data so is harmless.
4001      * we would not normally be fill'ing if there was data left in anycase.
4002      */
4003     if (PerlIO_flush(f) != 0)   /* XXXX Check that its seek() succeeded?! */
4004         return -1;
4005     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4006         PerlIOBase_flush_linebuf(aTHX);
4007
4008     if (!b->buf)
4009         PerlIO_get_base(f);     /* allocate via vtable */
4010
4011     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4012
4013     b->ptr = b->end = b->buf;
4014
4015     if (!PerlIOValid(n)) {
4016         PerlIOBase(f)->flags |= PERLIO_F_EOF;
4017         return -1;
4018     }
4019
4020     if (PerlIO_fast_gets(n)) {
4021         /*
4022          * Layer below is also buffered. We do _NOT_ want to call its
4023          * ->Read() because that will loop till it gets what we asked for
4024          * which may hang on a pipe etc. Instead take anything it has to
4025          * hand, or ask it to fill _once_.
4026          */
4027         avail = PerlIO_get_cnt(n);
4028         if (avail <= 0) {
4029             avail = PerlIO_fill(n);
4030             if (avail == 0)
4031                 avail = PerlIO_get_cnt(n);
4032             else {
4033                 if (!PerlIO_error(n) && PerlIO_eof(n))
4034                     avail = 0;
4035             }
4036         }
4037         if (avail > 0) {
4038             STDCHAR *ptr = PerlIO_get_ptr(n);
4039             const SSize_t cnt = avail;
4040             if (avail > (SSize_t)b->bufsiz)
4041                 avail = b->bufsiz;
4042             Copy(ptr, b->buf, avail, STDCHAR);
4043             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4044         }
4045     }
4046     else {
4047         avail = PerlIO_read(n, b->ptr, b->bufsiz);
4048     }
4049     if (avail <= 0) {
4050         if (avail == 0)
4051             PerlIOBase(f)->flags |= PERLIO_F_EOF;
4052         else
4053             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4054         return -1;
4055     }
4056     b->end = b->buf + avail;
4057     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4058     return 0;
4059 }
4060
4061 SSize_t
4062 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4063 {
4064     if (PerlIOValid(f)) {
4065         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4066         if (!b->ptr)
4067             PerlIO_get_base(f);
4068         return PerlIOBase_read(aTHX_ f, vbuf, count);
4069     }
4070     return 0;
4071 }
4072
4073 SSize_t
4074 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4075 {
4076     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4077     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4078     SSize_t unread = 0;
4079     SSize_t avail;
4080     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4081         PerlIO_flush(f);
4082     if (!b->buf)
4083         PerlIO_get_base(f);
4084     if (b->buf) {
4085         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4086             /*
4087              * Buffer is already a read buffer, we can overwrite any chars
4088              * which have been read back to buffer start
4089              */
4090             avail = (b->ptr - b->buf);
4091         }
4092         else {
4093             /*
4094              * Buffer is idle, set it up so whole buffer is available for
4095              * unread
4096              */
4097             avail = b->bufsiz;
4098             b->end = b->buf + avail;
4099             b->ptr = b->end;
4100             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4101             /*
4102              * Buffer extends _back_ from where we are now
4103              */
4104             b->posn -= b->bufsiz;
4105         }
4106         if (avail > (SSize_t) count) {
4107             /*
4108              * If we have space for more than count, just move count
4109              */
4110             avail = count;
4111         }
4112         if (avail > 0) {
4113             b->ptr -= avail;
4114             buf -= avail;
4115             /*
4116              * In simple stdio-like ungetc() case chars will be already
4117              * there
4118              */
4119             if (buf != b->ptr) {
4120                 Copy(buf, b->ptr, avail, STDCHAR);
4121             }
4122             count -= avail;
4123             unread += avail;
4124             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4125         }
4126     }
4127     if (count > 0) {
4128         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4129     }
4130     return unread;
4131 }
4132
4133 SSize_t
4134 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4135 {
4136     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4137     const STDCHAR *buf = (const STDCHAR *) vbuf;
4138     const STDCHAR *flushptr = buf;
4139     Size_t written = 0;
4140     if (!b->buf)
4141         PerlIO_get_base(f);
4142     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4143         return 0;
4144     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4145         if (PerlIO_flush(f) != 0) {
4146             return 0;
4147         }
4148     }   
4149     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4150         flushptr = buf + count;
4151         while (flushptr > buf && *(flushptr - 1) != '\n')
4152             --flushptr;
4153     }
4154     while (count > 0) {
4155         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4156         if ((SSize_t) count < avail)
4157             avail = count;
4158         if (flushptr > buf && flushptr <= buf + avail)
4159             avail = flushptr - buf;
4160         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4161         if (avail) {
4162             Copy(buf, b->ptr, avail, STDCHAR);
4163             count -= avail;
4164             buf += avail;
4165             written += avail;
4166             b->ptr += avail;
4167             if (buf == flushptr)
4168                 PerlIO_flush(f);
4169         }
4170         if (b->ptr >= (b->buf + b->bufsiz))
4171             if (PerlIO_flush(f) == -1)
4172                 return -1;
4173     }
4174     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4175         PerlIO_flush(f);
4176     return written;
4177 }
4178
4179 IV
4180 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4181 {
4182     IV code;
4183     if ((code = PerlIO_flush(f)) == 0) {
4184         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4185         code = PerlIO_seek(PerlIONext(f), offset, whence);
4186         if (code == 0) {
4187             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4188             b->posn = PerlIO_tell(PerlIONext(f));
4189         }
4190     }
4191     return code;
4192 }
4193
4194 Off_t
4195 PerlIOBuf_tell(pTHX_ PerlIO *f)
4196 {
4197     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4198     /*
4199      * b->posn is file position where b->buf was read, or will be written
4200      */
4201     Off_t posn = b->posn;
4202     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4203         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4204 #if 1
4205         /* As O_APPEND files are normally shared in some sense it is better
4206            to flush :
4207          */     
4208         PerlIO_flush(f);
4209 #else   
4210         /* when file is NOT shared then this is sufficient */
4211         PerlIO_seek(PerlIONext(f),0, SEEK_END);
4212 #endif
4213         posn = b->posn = PerlIO_tell(PerlIONext(f));
4214     }
4215     if (b->buf) {
4216         /*
4217          * If buffer is valid adjust position by amount in buffer
4218          */
4219         posn += (b->ptr - b->buf);
4220     }
4221     return posn;
4222 }
4223
4224 IV
4225 PerlIOBuf_popped(pTHX_ PerlIO *f)
4226 {
4227     const IV code = PerlIOBase_popped(aTHX_ f);
4228     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4229     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4230         Safefree(b->buf);
4231     }
4232     b->ptr = b->end = b->buf = NULL;
4233     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4234     return code;
4235 }
4236
4237 IV
4238 PerlIOBuf_close(pTHX_ PerlIO *f)
4239 {
4240     const IV code = PerlIOBase_close(aTHX_ f);
4241     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4242     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4243         Safefree(b->buf);
4244     }
4245     b->ptr = b->end = b->buf = NULL;
4246     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4247     return code;
4248 }
4249
4250 STDCHAR *
4251 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4252 {
4253     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4254     if (!b->buf)
4255         PerlIO_get_base(f);
4256     return b->ptr;
4257 }
4258
4259 SSize_t
4260 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4261 {
4262     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4263     if (!b->buf)
4264         PerlIO_get_base(f);
4265     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4266         return (b->end - b->ptr);
4267     return 0;
4268 }
4269
4270 STDCHAR *
4271 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4272 {
4273     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4274     PERL_UNUSED_CONTEXT;
4275
4276     if (!b->buf) {
4277         if (!b->bufsiz)
4278             b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4279         Newxz(b->buf,b->bufsiz, STDCHAR);
4280         if (!b->buf) {
4281             b->buf = (STDCHAR *) & b->oneword;
4282             b->bufsiz = sizeof(b->oneword);
4283         }
4284         b->end = b->ptr = b->buf;
4285     }
4286     return b->buf;
4287 }
4288
4289 Size_t
4290 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4291 {
4292     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4293     if (!b->buf)
4294         PerlIO_get_base(f);
4295     return (b->end - b->buf);
4296 }
4297
4298 void
4299 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4300 {
4301     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4302 #ifndef DEBUGGING
4303     PERL_UNUSED_ARG(cnt);
4304 #endif
4305     if (!b->buf)
4306         PerlIO_get_base(f);
4307     b->ptr = ptr;
4308     assert(PerlIO_get_cnt(f) == cnt);
4309     assert(b->ptr >= b->buf);
4310     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4311 }
4312
4313 PerlIO *
4314 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4315 {
4316  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4317 }
4318
4319
4320
4321 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4322     sizeof(PerlIO_funcs),
4323     "perlio",
4324     sizeof(PerlIOBuf),
4325     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4326     PerlIOBuf_pushed,
4327     PerlIOBuf_popped,
4328     PerlIOBuf_open,
4329     PerlIOBase_binmode,         /* binmode */
4330     NULL,
4331     PerlIOBase_fileno,
4332     PerlIOBuf_dup,
4333     PerlIOBuf_read,
4334     PerlIOBuf_unread,
4335     PerlIOBuf_write,
4336     PerlIOBuf_seek,
4337     PerlIOBuf_tell,
4338     PerlIOBuf_close,
4339     PerlIOBuf_flush,
4340     PerlIOBuf_fill,
4341     PerlIOBase_eof,
4342     PerlIOBase_error,
4343     PerlIOBase_clearerr,
4344     PerlIOBase_setlinebuf,
4345     PerlIOBuf_get_base,
4346     PerlIOBuf_bufsiz,
4347     PerlIOBuf_get_ptr,
4348     PerlIOBuf_get_cnt,
4349     PerlIOBuf_set_ptrcnt,
4350 };
4351
4352 /*--------------------------------------------------------------------------------------*/
4353 /*
4354  * Temp layer to hold unread chars when cannot do it any other way
4355  */
4356
4357 IV
4358 PerlIOPending_fill(pTHX_ PerlIO *f)
4359 {
4360     /*
4361      * Should never happen
4362      */
4363     PerlIO_flush(f);
4364     return 0;
4365 }
4366
4367 IV
4368 PerlIOPending_close(pTHX_ PerlIO *f)
4369 {
4370     /*
4371      * A tad tricky - flush pops us, then we close new top
4372      */
4373     PerlIO_flush(f);
4374     return PerlIO_close(f);
4375 }
4376
4377 IV
4378 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4379 {
4380     /*
4381      * A tad tricky - flush pops us, then we seek new top
4382      */
4383     PerlIO_flush(f);
4384     return PerlIO_seek(f, offset, whence);
4385 }
4386
4387
4388 IV
4389 PerlIOPending_flush(pTHX_ PerlIO *f)
4390 {
4391     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4392     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4393         Safefree(b->buf);
4394         b->buf = NULL;
4395     }
4396     PerlIO_pop(aTHX_ f);
4397     return 0;
4398 }
4399
4400 void
4401 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4402 {
4403     if (cnt <= 0) {
4404         PerlIO_flush(f);
4405     }
4406     else {
4407         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4408     }
4409 }
4410
4411 IV
4412 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4413 {
4414     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4415     PerlIOl * const l = PerlIOBase(f);
4416     /*
4417      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4418      * etc. get muddled when it changes mid-string when we auto-pop.
4419      */
4420     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4421         (PerlIOBase(PerlIONext(f))->
4422          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4423     return code;
4424 }
4425
4426 SSize_t
4427 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4428 {
4429     SSize_t avail = PerlIO_get_cnt(f);
4430     SSize_t got = 0;
4431     if ((SSize_t)count < avail)
4432         avail = count;
4433     if (avail > 0)
4434         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4435     if (got >= 0 && got < (SSize_t)count) {
4436         const SSize_t more =
4437             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4438         if (more >= 0 || got == 0)
4439             got += more;
4440     }
4441     return got;
4442 }
4443
4444 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4445     sizeof(PerlIO_funcs),
4446     "pending",
4447     sizeof(PerlIOBuf),
4448     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4449     PerlIOPending_pushed,
4450     PerlIOBuf_popped,
4451     NULL,
4452     PerlIOBase_binmode,         /* binmode */
4453     NULL,
4454     PerlIOBase_fileno,
4455     PerlIOBuf_dup,
4456     PerlIOPending_read,
4457     PerlIOBuf_unread,
4458     PerlIOBuf_write,
4459     PerlIOPending_seek,
4460     PerlIOBuf_tell,
4461     PerlIOPending_close,
4462     PerlIOPending_flush,
4463     PerlIOPending_fill,
4464     PerlIOBase_eof,
4465     PerlIOBase_error,
4466     PerlIOBase_clearerr,
4467     PerlIOBase_setlinebuf,
4468     PerlIOBuf_get_base,
4469     PerlIOBuf_bufsiz,
4470     PerlIOBuf_get_ptr,
4471     PerlIOBuf_get_cnt,
4472     PerlIOPending_set_ptrcnt,
4473 };
4474
4475
4476
4477 /*--------------------------------------------------------------------------------------*/
4478 /*
4479  * crlf - translation On read translate CR,LF to "\n" we do this by
4480  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4481  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4482  *
4483  * c->nl points on the first byte of CR LF pair when it is temporarily
4484  * replaced by LF, or to the last CR of the buffer.  In the former case
4485  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4486  * that it ends at c->nl; these two cases can be distinguished by
4487  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4488  * _unread() and _flush() calls.
4489  * It only matters for read operations.
4490  */
4491
4492 typedef struct {
4493     PerlIOBuf base;             /* PerlIOBuf stuff */
4494     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4495                                  * buffer */
4496 } PerlIOCrlf;
4497
4498 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4499  * Otherwise the :crlf layer would always revert back to
4500  * raw mode.
4501  */
4502 static void
4503 S_inherit_utf8_flag(PerlIO *f)
4504 {
4505     PerlIO *g = PerlIONext(f);
4506     if (PerlIOValid(g)) {
4507         if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4508             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4509         }
4510     }
4511 }
4512
4513 IV
4514 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4515 {
4516     IV code;
4517     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4518     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4519 #if 0
4520     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4521                  (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4522                  PerlIOBase(f)->flags);
4523 #endif
4524     {
4525       /* Enable the first CRLF capable layer you can find, but if none
4526        * found, the one we just pushed is fine.  This results in at
4527        * any given moment at most one CRLF-capable layer being enabled
4528        * in the whole layer stack. */
4529          PerlIO *g = PerlIONext(f);
4530          while (PerlIOValid(g)) {
4531               PerlIOl *b = PerlIOBase(g);
4532               if (b && b->tab == &PerlIO_crlf) {
4533                    if (!(b->flags & PERLIO_F_CRLF))
4534                         b->flags |= PERLIO_F_CRLF;
4535                    S_inherit_utf8_flag(g);
4536                    PerlIO_pop(aTHX_ f);
4537                    return code;
4538               }           
4539               g = PerlIONext(g);
4540          }
4541     }
4542     S_inherit_utf8_flag(f);
4543     return code;
4544 }
4545
4546
4547 SSize_t
4548 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4549 {
4550     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4551     if (c->nl) {        /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4552         *(c->nl) = 0xd;
4553         c->nl = NULL;
4554     }
4555     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4556         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4557     else {
4558         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4559         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4560         SSize_t unread = 0;
4561         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4562             PerlIO_flush(f);
4563         if (!b->buf)
4564             PerlIO_get_base(f);
4565         if (b->buf) {
4566             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4567                 b->end = b->ptr = b->buf + b->bufsiz;
4568                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4569                 b->posn -= b->bufsiz;
4570             }
4571             while (count > 0 && b->ptr > b->buf) {
4572                 const int ch = *--buf;
4573                 if (ch == '\n') {
4574                     if (b->ptr - 2 >= b->buf) {
4575                         *--(b->ptr) = 0xa;
4576                         *--(b->ptr) = 0xd;
4577                         unread++;
4578                         count--;
4579                     }
4580                     else {
4581                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4582                         *--(b->ptr) = 0xa;      /* Works even if 0xa == '\r' */
4583                         unread++;
4584                         count--;
4585                     }
4586                 }
4587                 else {
4588                     *--(b->ptr) = ch;
4589                     unread++;
4590                     count--;
4591                 }
4592             }
4593         }
4594         return unread;
4595     }
4596 }
4597
4598 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4599 SSize_t
4600 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4601 {
4602     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4603     if (!b->buf)
4604         PerlIO_get_base(f);
4605     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4606         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4607         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4608             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4609           scan:
4610             while (nl < b->end && *nl != 0xd)
4611                 nl++;
4612             if (nl < b->end && *nl == 0xd) {
4613               test:
4614                 if (nl + 1 < b->end) {
4615                     if (nl[1] == 0xa) {
4616                         *nl = '\n';
4617                         c->nl = nl;
4618                     }
4619                     else {
4620                         /*
4621                          * Not CR,LF but just CR
4622                          */
4623                         nl++;
4624                         goto scan;
4625                     }
4626                 }
4627                 else {
4628                     /*
4629                      * Blast - found CR as last char in buffer
4630                      */
4631
4632                     if (b->ptr < nl) {
4633                         /*
4634                          * They may not care, defer work as long as
4635                          * possible
4636                          */
4637                         c->nl = nl;
4638                         return (nl - b->ptr);
4639                     }
4640                     else {
4641                         int code;
4642                         b->ptr++;       /* say we have read it as far as
4643                                          * flush() is concerned */
4644                         b->buf++;       /* Leave space in front of buffer */
4645                         /* Note as we have moved buf up flush's
4646                            posn += ptr-buf
4647                            will naturally make posn point at CR
4648                          */
4649                         b->bufsiz--;    /* Buffer is thus smaller */
4650                         code = PerlIO_fill(f);  /* Fetch some more */
4651                         b->bufsiz++;    /* Restore size for next time */
4652                         b->buf--;       /* Point at space */
4653                         b->ptr = nl = b->buf;   /* Which is what we hand
4654                                                  * off */
4655                         *nl = 0xd;      /* Fill in the CR */
4656                         if (code == 0)
4657                             goto test;  /* fill() call worked */
4658                         /*
4659                          * CR at EOF - just fall through
4660                          */
4661                         /* Should we clear EOF though ??? */
4662                     }
4663                 }
4664             }
4665         }
4666         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4667     }
4668     return 0;
4669 }
4670
4671 void
4672 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4673 {
4674     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4675     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4676     if (!b->buf)
4677         PerlIO_get_base(f);
4678     if (!ptr) {
4679         if (c->nl) {
4680             ptr = c->nl + 1;
4681             if (ptr == b->end && *c->nl == 0xd) {
4682                 /* Deferred CR at end of buffer case - we lied about count */
4683                 ptr--;
4684             }
4685         }
4686         else {
4687             ptr = b->end;
4688         }
4689         ptr -= cnt;
4690     }
4691     else {
4692         NOOP;
4693 #if 0
4694         /*
4695          * Test code - delete when it works ...
4696          */
4697         IV flags = PerlIOBase(f)->flags;
4698         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4699         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4700           /* Deferred CR at end of buffer case - we lied about count */
4701           chk--;
4702         }
4703         chk -= cnt;
4704
4705         if (ptr != chk ) {
4706             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4707                        " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4708                        flags, c->nl, b->end, cnt);
4709         }
4710 #endif
4711     }
4712     if (c->nl) {
4713         if (ptr > c->nl) {
4714             /*
4715              * They have taken what we lied about
4716              */
4717             *(c->nl) = 0xd;
4718             c->nl = NULL;
4719             ptr++;
4720         }
4721     }
4722     b->ptr = ptr;
4723     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4724 }
4725
4726 SSize_t
4727 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4728 {
4729     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4730         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4731     else {
4732         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4733         const STDCHAR *buf = (const STDCHAR *) vbuf;
4734         const STDCHAR * const ebuf = buf + count;
4735         if (!b->buf)
4736             PerlIO_get_base(f);
4737         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4738             return 0;
4739         while (buf < ebuf) {
4740             const STDCHAR * const eptr = b->buf + b->bufsiz;
4741             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4742             while (buf < ebuf && b->ptr < eptr) {
4743                 if (*buf == '\n') {
4744                     if ((b->ptr + 2) > eptr) {
4745                         /*
4746                          * Not room for both
4747                          */
4748                         PerlIO_flush(f);
4749                         break;
4750                     }
4751                     else {
4752                         *(b->ptr)++ = 0xd;      /* CR */
4753                         *(b->ptr)++ = 0xa;      /* LF */
4754                         buf++;
4755                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4756                             PerlIO_flush(f);
4757                             break;
4758                         }
4759                     }
4760                 }
4761                 else {
4762                     *(b->ptr)++ = *buf++;
4763                 }
4764                 if (b->ptr >= eptr) {
4765                     PerlIO_flush(f);
4766                     break;
4767                 }
4768             }
4769         }
4770         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4771             PerlIO_flush(f);
4772         return (buf - (STDCHAR *) vbuf);
4773     }
4774 }
4775
4776 IV
4777 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4778 {
4779     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4780     if (c->nl) {
4781         *(c->nl) = 0xd;
4782         c->nl = NULL;
4783     }
4784     return PerlIOBuf_flush(aTHX_ f);
4785 }
4786
4787 IV
4788 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4789 {
4790     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4791         /* In text mode - flush any pending stuff and flip it */
4792         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4793 #ifndef PERLIO_USING_CRLF
4794         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4795         PerlIO_pop(aTHX_ f);
4796 #endif
4797     }
4798     return 0;
4799 }
4800
4801 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4802     sizeof(PerlIO_funcs),
4803     "crlf",
4804     sizeof(PerlIOCrlf),
4805     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4806     PerlIOCrlf_pushed,
4807     PerlIOBuf_popped,         /* popped */
4808     PerlIOBuf_open,
4809     PerlIOCrlf_binmode,       /* binmode */
4810     NULL,
4811     PerlIOBase_fileno,
4812     PerlIOBuf_dup,
4813     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4814     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4815     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4816     PerlIOBuf_seek,
4817     PerlIOBuf_tell,
4818     PerlIOBuf_close,
4819     PerlIOCrlf_flush,
4820     PerlIOBuf_fill,
4821     PerlIOBase_eof,
4822     PerlIOBase_error,
4823     PerlIOBase_clearerr,
4824     PerlIOBase_setlinebuf,
4825     PerlIOBuf_get_base,
4826     PerlIOBuf_bufsiz,
4827     PerlIOBuf_get_ptr,
4828     PerlIOCrlf_get_cnt,
4829     PerlIOCrlf_set_ptrcnt,
4830 };
4831
4832 #ifdef HAS_MMAP
4833 /*--------------------------------------------------------------------------------------*/
4834 /*
4835  * mmap as "buffer" layer
4836  */
4837
4838 typedef struct {
4839     PerlIOBuf base;             /* PerlIOBuf stuff */
4840     Mmap_t mptr;                /* Mapped address */
4841     Size_t len;                 /* mapped length */
4842     STDCHAR *bbuf;              /* malloced buffer if map fails */
4843 } PerlIOMmap;
4844
4845 IV
4846 PerlIOMmap_map(pTHX_ PerlIO *f)
4847 {
4848     dVAR;
4849     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4850     const IV flags = PerlIOBase(f)->flags;
4851     IV code = 0;
4852     if (m->len)
4853         abort();
4854     if (flags & PERLIO_F_CANREAD) {
4855         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4856         const int fd = PerlIO_fileno(f);
4857         Stat_t st;
4858         code = Fstat(fd, &st);
4859         if (code == 0 && S_ISREG(st.st_mode)) {
4860             SSize_t len = st.st_size - b->posn;
4861             if (len > 0) {
4862                 Off_t posn;
4863                 if (PL_mmap_page_size <= 0)
4864                   Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4865                              PL_mmap_page_size);
4866                 if (b->posn < 0) {
4867                     /*
4868                      * This is a hack - should never happen - open should
4869                      * have set it !
4870                      */
4871                     b->posn = PerlIO_tell(PerlIONext(f));
4872                 }
4873                 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4874                 len = st.st_size - posn;
4875                 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4876                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4877 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4878                     madvise(m->mptr, len, MADV_SEQUENTIAL);
4879 #endif
4880 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4881                     madvise(m->mptr, len, MADV_WILLNEED);
4882 #endif
4883                     PerlIOBase(f)->flags =
4884                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4885                     b->end = ((STDCHAR *) m->mptr) + len;
4886                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4887                   &