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