3 * Copyright (c) 1996-2000, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in iperlsys.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #if !defined(PERL_IMPLICIT_SYS)
33 #ifdef PERLIO_IS_STDIO
38 /* Does nothing (yet) except force this file to be included
39 in perl binary. That allows this file to force inclusion
40 of other functions that may be required by loadable
41 extensions e.g. for FileHandle::tmpfile
52 #else /* PERLIO_IS_STDIO */
59 /* This section is just to make sure these functions
60 get pulled in from libsfio.a
73 /* Force this file to be included in perl binary. Which allows
74 * this file to force inclusion of other functions that may be
75 * required by loadable extensions e.g. for FileHandle::tmpfile
79 * sfio does its own 'autoflush' on stdout in common cases.
80 * Flush results in a lot of lseek()s to regular files and
81 * lot of small writes to pipes.
83 sfset(sfstdout,SF_SHARE,0);
87 /*======================================================================================*/
88 /* Implement all the PerlIO interface ourselves.
91 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
97 void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
100 PerlIO_debug(char *fmt,...)
105 char *s = getenv("PERLIO_DEBUG");
107 dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
115 SV *sv = newSVpvn("",0);
119 sv_vcatpvf(sv, fmt, &ap);
127 /*--------------------------------------------------------------------------------------*/
134 IV (*Fileno)(PerlIO *f);
135 PerlIO * (*Fdopen)(int fd, const char *mode);
136 PerlIO * (*Open)(const char *path, const char *mode);
137 int (*Reopen)(const char *path, const char *mode, PerlIO *f);
138 /* Unix-like functions - cf sfio line disciplines */
139 SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
140 SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
141 SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
142 IV (*Seek)(PerlIO *f, Off_t offset, int whence);
143 Off_t (*Tell)(PerlIO *f);
144 IV (*Close)(PerlIO *f);
145 /* Stdio-like buffered IO functions */
146 IV (*Flush)(PerlIO *f);
147 IV (*Eof)(PerlIO *f);
148 IV (*Error)(PerlIO *f);
149 void (*Clearerr)(PerlIO *f);
150 void (*Setlinebuf)(PerlIO *f);
151 /* Perl's snooping functions */
152 STDCHAR * (*Get_base)(PerlIO *f);
153 Size_t (*Get_bufsiz)(PerlIO *f);
154 STDCHAR * (*Get_ptr)(PerlIO *f);
155 SSize_t (*Get_cnt)(PerlIO *f);
156 void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
162 PerlIOl * next; /* Lower layer */
163 PerlIO_funcs * tab; /* Functions for this layer */
164 IV flags; /* Various flags for state */
167 /*--------------------------------------------------------------------------------------*/
170 #define PERLIO_F_EOF 0x0010000
171 #define PERLIO_F_CANWRITE 0x0020000
172 #define PERLIO_F_CANREAD 0x0040000
173 #define PERLIO_F_ERROR 0x0080000
174 #define PERLIO_F_TRUNCATE 0x0100000
175 #define PERLIO_F_APPEND 0x0200000
176 #define PERLIO_F_BINARY 0x0400000
177 #define PERLIO_F_TEMP 0x0800000
178 #define PERLIO_F_LINEBUF 0x0100000
179 #define PERLIO_F_WRBUF 0x2000000
180 #define PERLIO_F_RDBUF 0x4000000
181 #define PERLIO_F_OPEN 0x8000000
183 #define PerlIOBase(f) (*(f))
184 #define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
185 #define PerlIONext(f) (&(PerlIOBase(f)->next))
187 /*--------------------------------------------------------------------------------------*/
188 /* Inner level routines */
190 /* Table of pointers to the PerlIO structs (malloc'ed) */
191 PerlIO **_perlio = NULL;
192 int _perlio_size = 0;
195 PerlIO_allocate(void)
197 /* Find a free slot in the table, growing table as necessary */
202 PerlIO **table = _perlio;
203 while (i < _perlio_size)
208 Newz('F',f,1,PerlIO);
215 PerlIO_debug(__FUNCTION__ " f=%p\n",f);
220 Newz('I',table,_perlio_size+16,PerlIO *);
223 Copy(_perlio,table,_perlio_size,PerlIO *);
232 PerlIO_pop(PerlIO *f)
244 PerlIO_close(PerlIO *f)
246 int code = (*PerlIOBase(f)->tab->Close)(f);
257 /* Close all the files */
259 for (i=_perlio_size-1; i >= 0; i--)
261 PerlIO *f = _perlio[i];
277 /*--------------------------------------------------------------------------------------*/
278 /* Given the abstraction above the public API functions */
282 PerlIO_fileno(PerlIO *f)
284 return (*PerlIOBase(f)->tab->Fileno)(f);
287 extern PerlIO_funcs PerlIO_unix;
288 extern PerlIO_funcs PerlIO_stdio;
289 extern PerlIO_funcs PerlIO_perlio;
291 #define PerlIO_default_top() &PerlIO_stdio
292 #define PerlIO_default_btm() &PerlIO_unix
296 PerlIO_fdopen(int fd, const char *mode)
298 PerlIO_funcs *tab = PerlIO_default_top();
299 return (*tab->Fdopen)(fd,mode);
304 PerlIO_open(const char *path, const char *mode)
306 PerlIO_funcs *tab = PerlIO_default_top();
307 return (*tab->Open)(path,mode);
311 PerlIOBase_init(PerlIO *f, const char *mode)
313 PerlIOl *l = PerlIOBase(f);
314 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
315 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
321 l->flags = PERLIO_F_CANREAD;
324 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
327 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
338 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
341 l->flags |= PERLIO_F_BINARY;
353 l->flags |= l->next->flags &
354 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
355 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
363 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
368 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
370 PerlIOBase_init(f,mode);
376 return PerlIO_open(path,mode);
381 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
383 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
388 PerlIO_ungetc(PerlIO *f, int ch)
391 if ((*PerlIOBase(f)->tab->Unread)(f,&buf,1) == 1)
398 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
400 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
405 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
407 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
412 PerlIO_tell(PerlIO *f)
414 return (*PerlIOBase(f)->tab->Tell)(f);
419 PerlIO_flush(PerlIO *f)
423 return (*PerlIOBase(f)->tab->Flush)(f);
429 for (i=_perlio_size-1; i >= 0; i--)
431 if ((f = _perlio[i]))
433 if (*f && PerlIO_flush(f) != 0)
443 PerlIO_eof(PerlIO *f)
445 return (*PerlIOBase(f)->tab->Eof)(f);
450 PerlIO_error(PerlIO *f)
452 return (*PerlIOBase(f)->tab->Error)(f);
455 #undef PerlIO_clearerr
457 PerlIO_clearerr(PerlIO *f)
459 (*PerlIOBase(f)->tab->Clearerr)(f);
462 #undef PerlIO_setlinebuf
464 PerlIO_setlinebuf(PerlIO *f)
466 (*PerlIOBase(f)->tab->Setlinebuf)(f);
469 #undef PerlIO_has_base
471 PerlIO_has_base(PerlIO *f)
475 return (PerlIOBase(f)->tab->Get_base != NULL);
480 #undef PerlIO_fast_gets
482 PerlIO_fast_gets(PerlIO *f)
486 return (PerlIOBase(f)->tab->Set_ptrcnt != NULL);
491 #undef PerlIO_has_cntptr
493 PerlIO_has_cntptr(PerlIO *f)
497 PerlIO_funcs *tab = PerlIOBase(f)->tab;
498 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
503 #undef PerlIO_canset_cnt
505 PerlIO_canset_cnt(PerlIO *f)
509 return (PerlIOBase(f)->tab->Set_ptrcnt != NULL);
514 #undef PerlIO_get_base
516 PerlIO_get_base(PerlIO *f)
518 return (*PerlIOBase(f)->tab->Get_base)(f);
521 #undef PerlIO_get_bufsiz
523 PerlIO_get_bufsiz(PerlIO *f)
525 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
528 #undef PerlIO_get_ptr
530 PerlIO_get_ptr(PerlIO *f)
532 return (*PerlIOBase(f)->tab->Get_ptr)(f);
535 #undef PerlIO_get_cnt
537 PerlIO_get_cnt(PerlIO *f)
539 return (*PerlIOBase(f)->tab->Get_cnt)(f);
542 #undef PerlIO_set_cnt
544 PerlIO_set_cnt(PerlIO *f,SSize_t cnt)
546 return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
549 #undef PerlIO_set_ptrcnt
551 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
553 return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
556 /*--------------------------------------------------------------------------------------*/
557 /* "Methods" of the "base class" */
560 PerlIOBase_fileno(PerlIO *f)
562 return PerlIO_fileno(PerlIONext(f));
566 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
569 Newc('L',l,tab->size,char,PerlIOl);
572 Zero(l,tab->size,char);
576 PerlIOBase_init(f,mode);
577 PerlIO_debug(__FUNCTION__ " f=%p %08lX %s\n",f,PerlIOBase(f)->flags,tab->name);
583 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
585 Off_t old = PerlIO_tell(f);
586 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
588 Off_t new = PerlIO_tell(f);
595 PerlIOBase_sync(PerlIO *f)
601 PerlIOBase_close(PerlIO *f)
604 if (PerlIO_flush(f) != 0)
606 if (PerlIO_close(PerlIONext(f)) != 0)
608 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
613 PerlIOBase_eof(PerlIO *f)
617 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
623 PerlIOBase_error(PerlIO *f)
627 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
633 PerlIOBase_clearerr(PerlIO *f)
637 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
642 PerlIOBase_setlinebuf(PerlIO *f)
649 /*--------------------------------------------------------------------------------------*/
650 /* Bottom-most level for UNIX-like case */
654 struct _PerlIO base; /* The generic part */
655 int fd; /* UNIX like file descriptor */
656 int oflags; /* open/fcntl flags */
660 PerlIOUnix_oflags(const char *mode)
675 oflags = O_CREAT|O_TRUNC;
686 oflags = O_CREAT|O_APPEND;
696 if (*mode || oflags == -1)
705 PerlIOUnix_fileno(PerlIO *f)
707 return PerlIOSelf(f,PerlIOUnix)->fd;
711 PerlIOUnix_fdopen(int fd,const char *mode)
716 int oflags = PerlIOUnix_oflags(mode);
719 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
722 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
729 PerlIOUnix_open(const char *path,const char *mode)
732 int oflags = PerlIOUnix_oflags(mode);
735 int fd = open(path,oflags,0666);
738 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
741 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
748 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
750 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
751 int oflags = PerlIOUnix_oflags(mode);
752 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
753 (*PerlIOBase(f)->tab->Close)(f);
756 int fd = open(path,oflags,0666);
761 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
769 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
771 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
774 SSize_t len = read(fd,vbuf,count);
775 if (len >= 0 || errno != EINTR)
781 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
783 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
786 SSize_t len = write(fd,vbuf,count);
787 if (len >= 0 || errno != EINTR)
793 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
795 Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
796 return (new == (Off_t) -1) ? -1 : 0;
800 PerlIOUnix_tell(PerlIO *f)
802 return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
806 PerlIOUnix_close(PerlIO *f)
808 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
810 while (close(fd) != 0)
820 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
825 PerlIO_funcs PerlIO_unix = {
843 PerlIOBase_setlinebuf,
845 NULL, /* get_bufsiz */
848 NULL, /* set_ptrcnt */
851 /*--------------------------------------------------------------------------------------*/
852 /* stdio as a layer */
857 FILE * stdio; /* The stream */
861 PerlIOStdio_fileno(PerlIO *f)
863 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
868 PerlIOStdio_fdopen(int fd,const char *mode)
873 FILE *stdio = fdopen(fd,mode);
876 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
883 #undef PerlIO_importFILE
885 PerlIO_importFILE(FILE *stdio, int fl)
890 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
897 PerlIOStdio_open(const char *path,const char *mode)
900 FILE *stdio = fopen(path,mode);
903 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
910 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
912 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
913 FILE *stdio = freopen(path,mode,s->stdio);
921 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
923 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
926 STDCHAR *buf = (STDCHAR *) vbuf;
927 /* Perl is expecting PerlIO_getc() to fill the buffer
928 * Linux's stdio does not do that for fread()
938 return fread(vbuf,1,count,s);
942 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
944 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
945 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
949 int ch = *buf-- & 0xff;
950 if (ungetc(ch,s) != ch)
959 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
961 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
965 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
967 return fseek(PerlIOSelf(f,PerlIOStdio)->stdio,offset,whence);
971 PerlIOStdio_tell(PerlIO *f)
973 return ftell(PerlIOSelf(f,PerlIOStdio)->stdio);
977 PerlIOStdio_close(PerlIO *f)
979 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
983 PerlIOStdio_flush(PerlIO *f)
985 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
986 return fflush(stdio);
990 PerlIOStdio_eof(PerlIO *f)
992 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
996 PerlIOStdio_error(PerlIO *f)
998 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1002 PerlIOStdio_clearerr(PerlIO *f)
1004 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1008 PerlIOStdio_setlinebuf(PerlIO *f)
1010 #ifdef HAS_SETLINEBUF
1011 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1013 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1019 PerlIOStdio_get_base(PerlIO *f)
1021 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1022 return FILE_base(stdio);
1026 PerlIOStdio_get_bufsiz(PerlIO *f)
1028 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1029 return FILE_bufsiz(stdio);
1033 #ifdef USE_STDIO_PTR
1035 PerlIOStdio_get_ptr(PerlIO *f)
1037 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1038 return FILE_ptr(stdio);
1042 PerlIOStdio_get_cnt(PerlIO *f)
1044 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1045 return FILE_cnt(stdio);
1049 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1051 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1054 #ifdef STDIO_PTR_LVALUE
1055 FILE_ptr(stdio) = ptr;
1056 #ifdef STDIO_PTR_LVAL_SETS_CNT
1057 if (FILE_cnt(stdio) != (cnt))
1060 assert(FILE_cnt(stdio) == (cnt));
1063 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1064 /* Setting ptr _does_ change cnt - we are done */
1067 #else /* STDIO_PTR_LVALUE */
1069 #endif /* STDIO_PTR_LVALUE */
1071 /* Now (or only) set cnt */
1072 #ifdef STDIO_CNT_LVALUE
1073 FILE_cnt(stdio) = cnt;
1074 #else /* STDIO_CNT_LVALUE */
1075 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1076 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1077 #else /* STDIO_PTR_LVAL_SETS_CNT */
1079 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1080 #endif /* STDIO_CNT_LVALUE */
1085 PerlIO_funcs PerlIO_stdio = {
1087 sizeof(PerlIOStdio),
1102 PerlIOStdio_clearerr,
1103 PerlIOStdio_setlinebuf,
1105 PerlIOStdio_get_base,
1106 PerlIOStdio_get_bufsiz,
1111 #ifdef USE_STDIO_PTR
1112 PerlIOStdio_get_ptr,
1113 PerlIOStdio_get_cnt,
1114 #if (defined(STDIO_PTR_LVALUE) && \
1115 (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1116 PerlIOStdio_set_ptrcnt
1117 #else /* STDIO_PTR_LVALUE */
1119 #endif /* STDIO_PTR_LVALUE */
1120 #else /* USE_STDIO_PTR */
1124 #endif /* USE_STDIO_PTR */
1127 #undef PerlIO_exportFILE
1129 PerlIO_exportFILE(PerlIO *f, int fl)
1132 /* Should really push stdio discipline when we have them */
1133 return fdopen(PerlIO_fileno(f),"r+");
1136 #undef PerlIO_findFILE
1138 PerlIO_findFILE(PerlIO *f)
1140 return PerlIO_exportFILE(f,0);
1143 #undef PerlIO_releaseFILE
1145 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1149 /*--------------------------------------------------------------------------------------*/
1150 /* perlio buffer layer */
1154 struct _PerlIO base;
1155 Off_t posn; /* Offset of buf into the file */
1156 STDCHAR * buf; /* Start of buffer */
1157 STDCHAR * end; /* End of valid part of buffer */
1158 STDCHAR * ptr; /* Current position in buffer */
1159 Size_t bufsiz; /* Size of buffer */
1160 IV oneword; /* Emergency buffer */
1165 PerlIOBuf_fdopen(int fd, const char *mode)
1167 PerlIO_funcs *tab = PerlIO_default_btm();
1168 PerlIO *f = (*tab->Fdopen)(fd,mode);
1171 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1172 b->posn = PerlIO_tell(PerlIONext(f));
1178 PerlIOBuf_open(const char *path, const char *mode)
1180 PerlIO_funcs *tab = PerlIO_default_btm();
1181 PerlIO *f = (*tab->Open)(path,mode);
1184 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1191 PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1193 return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1197 PerlIOBuf_alloc_buf(PerlIOBuf *b)
1201 New('B',b->buf,b->bufsiz,char);
1204 b->buf = (STDCHAR *)&b->oneword;
1205 b->bufsiz = sizeof(b->oneword);
1211 /* This "flush" is akin to sfio's sync in that it handles files in either
1215 PerlIOBuf_flush(PerlIO *f)
1217 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1219 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1221 /* write() the buffer */
1222 STDCHAR *p = b->buf;
1226 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1233 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1238 b->posn += (p - b->buf);
1240 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1242 /* Note position change */
1243 b->posn += (b->ptr - b->buf);
1244 if (b->ptr < b->end)
1246 /* We did not consume all of it */
1247 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1249 b->posn = PerlIO_tell(PerlIONext(f));
1253 b->ptr = b->end = b->buf;
1254 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1255 if (PerlIO_flush(PerlIONext(f)) != 0)
1261 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1263 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1264 STDCHAR *buf = (STDCHAR *) vbuf;
1269 PerlIOBuf_alloc_buf(b);
1270 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1274 SSize_t avail = (b->end - b->ptr);
1275 if ((SSize_t) count < avail)
1279 Copy(b->ptr,buf,avail,char);
1285 if (count && (b->ptr >= b->end))
1288 b->ptr = b->end = b->buf;
1289 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1293 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1295 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1298 b->end = b->buf+avail;
1299 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1308 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1310 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1311 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1315 PerlIOBuf_alloc_buf(b);
1316 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1320 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1322 avail = (b->ptr - b->buf);
1323 if (avail > (SSize_t) count)
1330 if (avail > (SSize_t) count)
1332 b->end = b->ptr + avail;
1339 Copy(buf,b->ptr,avail,char);
1343 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1350 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1352 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1353 const STDCHAR *buf = (const STDCHAR *) vbuf;
1356 PerlIOBuf_alloc_buf(b);
1357 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1361 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1362 if ((SSize_t) count < avail)
1364 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1365 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1385 Copy(buf,b->ptr,avail,char);
1392 if (b->ptr >= (b->buf + b->bufsiz))
1399 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1401 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1403 code = PerlIO_flush(f);
1406 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1407 code = PerlIO_seek(PerlIONext(f),offset,whence);
1410 b->posn = PerlIO_tell(PerlIONext(f));
1417 PerlIOBuf_tell(PerlIO *f)
1419 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1420 Off_t posn = b->posn;
1422 posn += (b->ptr - b->buf);
1427 PerlIOBuf_close(PerlIO *f)
1429 IV code = PerlIOBase_close(f);
1430 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1431 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1436 b->ptr = b->end = b->buf;
1437 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1442 PerlIOBuf_setlinebuf(PerlIO *f)
1446 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1451 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1453 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1456 PerlIOBuf_alloc_buf(b);
1457 b->ptr = b->end - cnt;
1458 assert(b->ptr >= b->buf);
1462 PerlIOBuf_get_ptr(PerlIO *f)
1464 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1466 PerlIOBuf_alloc_buf(b);
1471 PerlIOBuf_get_cnt(PerlIO *f)
1473 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1475 PerlIOBuf_alloc_buf(b);
1476 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1477 return (b->end - b->ptr);
1482 PerlIOBuf_get_base(PerlIO *f)
1484 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1486 PerlIOBuf_alloc_buf(b);
1491 PerlIOBuf_bufsiz(PerlIO *f)
1493 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1495 PerlIOBuf_alloc_buf(b);
1496 return (b->end - b->buf);
1500 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1502 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1504 PerlIOBuf_alloc_buf(b);
1506 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1509 assert(PerlIO_get_cnt(f) == cnt);
1510 assert(b->ptr >= b->buf);
1512 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1515 PerlIO_funcs PerlIO_perlio = {
1532 PerlIOBase_clearerr,
1533 PerlIOBuf_setlinebuf,
1538 PerlIOBuf_set_ptrcnt,
1546 atexit(&PerlIO_cleanup);
1547 PerlIO_fdopen(0,"r");
1548 PerlIO_fdopen(1,"w");
1549 PerlIO_fdopen(2,"w");
1562 #undef PerlIO_stdout
1571 #undef PerlIO_stderr
1580 /*--------------------------------------------------------------------------------------*/
1582 #undef PerlIO_getname
1584 PerlIO_getname(PerlIO *f, char *buf)
1587 Perl_croak(aTHX_ "Don't know how to get file name");
1592 /*--------------------------------------------------------------------------------------*/
1593 /* Functions which can be called on any kind of PerlIO implemented
1599 PerlIO_getc(PerlIO *f)
1602 int count = PerlIO_read(f,&buf,1);
1604 return (unsigned char) buf;
1610 PerlIO_putc(PerlIO *f, int ch)
1613 return PerlIO_write(f,&buf,1);
1618 PerlIO_puts(PerlIO *f, const char *s)
1620 STRLEN len = strlen(s);
1621 return PerlIO_write(f,s,len);
1624 #undef PerlIO_rewind
1626 PerlIO_rewind(PerlIO *f)
1628 PerlIO_seek(f,(Off_t)0,SEEK_SET);
1632 #undef PerlIO_vprintf
1634 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1637 SV *sv = newSVpvn("",0);
1640 sv_vcatpvf(sv, fmt, &ap);
1642 return PerlIO_write(f,s,len);
1645 #undef PerlIO_printf
1647 PerlIO_printf(PerlIO *f,const char *fmt,...)
1652 result = PerlIO_vprintf(f,fmt,ap);
1657 #undef PerlIO_stdoutf
1659 PerlIO_stdoutf(const char *fmt,...)
1664 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1669 #undef PerlIO_tmpfile
1671 PerlIO_tmpfile(void)
1674 /* I have no idea how portable mkstemp() is ... */
1675 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1676 int fd = mkstemp(SvPVX(sv));
1680 f = PerlIO_fdopen(fd,"w+");
1683 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
1694 #endif /* USE_SFIO */
1695 #endif /* PERLIO_IS_STDIO */
1697 /*======================================================================================*/
1698 /* Now some functions in terms of above which may be needed even if
1699 we are not in true PerlIO mode
1703 #undef PerlIO_setpos
1705 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1707 return PerlIO_seek(f,*pos,0);
1710 #ifndef PERLIO_IS_STDIO
1711 #undef PerlIO_setpos
1713 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1715 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1716 return fsetpos64(f, pos);
1718 return fsetpos(f, pos);
1725 #undef PerlIO_getpos
1727 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1729 *pos = PerlIO_tell(f);
1733 #ifndef PERLIO_IS_STDIO
1734 #undef PerlIO_getpos
1736 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1738 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1739 return fgetpos64(f, pos);
1741 return fgetpos(f, pos);
1747 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1750 vprintf(char *pat, char *args)
1752 _doprnt(pat, args, stdout);
1753 return 0; /* wrong, but perl doesn't use the return value */
1757 vfprintf(FILE *fd, char *pat, char *args)
1759 _doprnt(pat, args, fd);
1760 return 0; /* wrong, but perl doesn't use the return value */
1765 #ifndef PerlIO_vsprintf
1767 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1769 int val = vsprintf(s, fmt, ap);
1772 if (strlen(s) >= (STRLEN)n)
1775 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1783 #ifndef PerlIO_sprintf
1785 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1790 result = PerlIO_vsprintf(s, n, fmt, ap);
1796 #endif /* !PERL_IMPLICIT_SYS */