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