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