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