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