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