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