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