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