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