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