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 s = CopFILE(PL_curcop);
122 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
123 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
132 /*--------------------------------------------------------------------------------------*/
139 IV (*Fileno)(PerlIO *f);
140 PerlIO * (*Fdopen)(int fd, const char *mode);
141 PerlIO * (*Open)(const char *path, const char *mode);
142 int (*Reopen)(const char *path, const char *mode, PerlIO *f);
143 /* Unix-like functions - cf sfio line disciplines */
144 SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
145 SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
146 SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
147 IV (*Seek)(PerlIO *f, Off_t offset, int whence);
148 Off_t (*Tell)(PerlIO *f);
149 IV (*Close)(PerlIO *f);
150 /* Stdio-like buffered IO functions */
151 IV (*Flush)(PerlIO *f);
152 IV (*Eof)(PerlIO *f);
153 IV (*Error)(PerlIO *f);
154 void (*Clearerr)(PerlIO *f);
155 void (*Setlinebuf)(PerlIO *f);
156 /* Perl's snooping functions */
157 STDCHAR * (*Get_base)(PerlIO *f);
158 Size_t (*Get_bufsiz)(PerlIO *f);
159 STDCHAR * (*Get_ptr)(PerlIO *f);
160 SSize_t (*Get_cnt)(PerlIO *f);
161 void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
167 PerlIOl * next; /* Lower layer */
168 PerlIO_funcs * tab; /* Functions for this layer */
169 IV flags; /* Various flags for state */
172 /*--------------------------------------------------------------------------------------*/
175 #define PERLIO_F_EOF 0x0010000
176 #define PERLIO_F_CANWRITE 0x0020000
177 #define PERLIO_F_CANREAD 0x0040000
178 #define PERLIO_F_ERROR 0x0080000
179 #define PERLIO_F_TRUNCATE 0x0100000
180 #define PERLIO_F_APPEND 0x0200000
181 #define PERLIO_F_BINARY 0x0400000
182 #define PERLIO_F_TEMP 0x0800000
183 #define PERLIO_F_LINEBUF 0x0100000
184 #define PERLIO_F_WRBUF 0x2000000
185 #define PERLIO_F_RDBUF 0x4000000
186 #define PERLIO_F_OPEN 0x8000000
188 #define PerlIOBase(f) (*(f))
189 #define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
190 #define PerlIONext(f) (&(PerlIOBase(f)->next))
192 /*--------------------------------------------------------------------------------------*/
193 /* Inner level routines */
195 /* Table of pointers to the PerlIO structs (malloc'ed) */
196 PerlIO *_perlio = NULL;
197 #define PERLIO_TABLE_SIZE 64
200 PerlIO_allocate(void)
202 /* Find a free slot in the table, growing table as necessary */
203 PerlIO **last = &_perlio;
208 last = (PerlIO **)(f);
209 for (i=1; i < PERLIO_TABLE_SIZE; i++)
217 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
225 PerlIO_cleantable(PerlIO **tablep)
227 PerlIO *table = *tablep;
231 PerlIO_cleantable((PerlIO **) &(table[0]));
232 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
246 PerlIO_cleantable(&_perlio);
250 PerlIO_pop(PerlIO *f)
262 PerlIO_close(PerlIO *f)
264 int code = (*PerlIOBase(f)->tab->Close)(f);
273 /*--------------------------------------------------------------------------------------*/
274 /* Given the abstraction above the public API functions */
278 PerlIO_fileno(PerlIO *f)
280 return (*PerlIOBase(f)->tab->Fileno)(f);
283 extern PerlIO_funcs PerlIO_unix;
284 extern PerlIO_funcs PerlIO_stdio;
285 extern PerlIO_funcs PerlIO_perlio;
287 #define PerlIO_default_top() &PerlIO_stdio
288 #define PerlIO_default_btm() &PerlIO_unix
292 PerlIO_fdopen(int fd, const char *mode)
294 PerlIO_funcs *tab = PerlIO_default_top();
295 return (*tab->Fdopen)(fd,mode);
300 PerlIO_open(const char *path, const char *mode)
302 PerlIO_funcs *tab = PerlIO_default_top();
303 return (*tab->Open)(path,mode);
307 PerlIOBase_init(PerlIO *f, const char *mode)
309 PerlIOl *l = PerlIOBase(f);
310 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
311 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
317 l->flags = PERLIO_F_CANREAD;
320 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
323 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
334 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
337 l->flags |= PERLIO_F_BINARY;
349 l->flags |= l->next->flags &
350 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
351 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
359 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
364 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
366 PerlIOBase_init(f,mode);
372 return PerlIO_open(path,mode);
377 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
379 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
384 PerlIO_ungetc(PerlIO *f, int ch)
387 if ((*PerlIOBase(f)->tab->Unread)(f,&buf,1) == 1)
394 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
396 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
401 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
403 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
408 PerlIO_tell(PerlIO *f)
410 return (*PerlIOBase(f)->tab->Tell)(f);
415 PerlIO_flush(PerlIO *f)
419 return (*PerlIOBase(f)->tab->Flush)(f);
423 PerlIO **table = &_perlio;
428 table = (PerlIO **)(f++);
429 for (i=1; i < PERLIO_TABLE_SIZE; i++)
431 if (*f && PerlIO_flush(f) != 0)
442 PerlIO_eof(PerlIO *f)
444 return (*PerlIOBase(f)->tab->Eof)(f);
449 PerlIO_error(PerlIO *f)
451 return (*PerlIOBase(f)->tab->Error)(f);
454 #undef PerlIO_clearerr
456 PerlIO_clearerr(PerlIO *f)
458 (*PerlIOBase(f)->tab->Clearerr)(f);
461 #undef PerlIO_setlinebuf
463 PerlIO_setlinebuf(PerlIO *f)
465 (*PerlIOBase(f)->tab->Setlinebuf)(f);
468 #undef PerlIO_has_base
470 PerlIO_has_base(PerlIO *f)
474 return (PerlIOBase(f)->tab->Get_base != NULL);
479 #undef PerlIO_fast_gets
481 PerlIO_fast_gets(PerlIO *f)
485 PerlIOl *l = PerlIOBase(f);
486 return (l->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 PerlIOl *l = PerlIOBase(f);
510 return (l->tab->Set_ptrcnt != NULL);
515 #undef PerlIO_get_base
517 PerlIO_get_base(PerlIO *f)
519 return (*PerlIOBase(f)->tab->Get_base)(f);
522 #undef PerlIO_get_bufsiz
524 PerlIO_get_bufsiz(PerlIO *f)
526 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
529 #undef PerlIO_get_ptr
531 PerlIO_get_ptr(PerlIO *f)
533 return (*PerlIOBase(f)->tab->Get_ptr)(f);
536 #undef PerlIO_get_cnt
538 PerlIO_get_cnt(PerlIO *f)
540 return (*PerlIOBase(f)->tab->Get_cnt)(f);
543 #undef PerlIO_set_cnt
545 PerlIO_set_cnt(PerlIO *f,int cnt)
547 return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
550 #undef PerlIO_set_ptrcnt
552 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
554 return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
557 /*--------------------------------------------------------------------------------------*/
558 /* "Methods" of the "base class" */
561 PerlIOBase_fileno(PerlIO *f)
563 return PerlIO_fileno(PerlIONext(f));
567 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
570 Newc('L',l,tab->size,char,PerlIOl);
573 Zero(l,tab->size,char);
577 PerlIOBase_init(f,mode);
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)
718 int oflags = PerlIOUnix_oflags(mode);
721 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
724 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
731 PerlIOUnix_open(const char *path,const char *mode)
734 int oflags = PerlIOUnix_oflags(mode);
737 int fd = open(path,oflags,0666);
740 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
743 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
750 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
752 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
753 int oflags = PerlIOUnix_oflags(mode);
754 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
755 (*PerlIOBase(f)->tab->Close)(f);
758 int fd = open(path,oflags,0666);
763 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
771 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
773 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
776 SSize_t len = read(fd,vbuf,count);
777 if (len >= 0 || errno != EINTR)
783 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
785 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
788 SSize_t len = write(fd,vbuf,count);
789 if (len >= 0 || errno != EINTR)
795 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
797 Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
798 return (new == (Off_t) -1) ? -1 : 0;
802 PerlIOUnix_tell(PerlIO *f)
804 return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
808 PerlIOUnix_close(PerlIO *f)
810 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
812 while (close(fd) != 0)
822 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
827 PerlIO_funcs PerlIO_unix = {
845 PerlIOBase_setlinebuf,
847 NULL, /* get_bufsiz */
850 NULL, /* set_ptrcnt */
853 /*--------------------------------------------------------------------------------------*/
854 /* stdio as a layer */
859 FILE * stdio; /* The stream */
863 PerlIOStdio_fileno(PerlIO *f)
865 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
870 PerlIOStdio_fdopen(int fd,const char *mode)
898 stdio = fdopen(fd,mode);
901 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
908 #undef PerlIO_importFILE
910 PerlIO_importFILE(FILE *stdio, int fl)
915 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
922 PerlIOStdio_open(const char *path,const char *mode)
925 FILE *stdio = fopen(path,mode);
928 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
935 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
937 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
938 FILE *stdio = freopen(path,mode,s->stdio);
946 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
948 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
952 STDCHAR *buf = (STDCHAR *) vbuf;
953 /* Perl is expecting PerlIO_getc() to fill the buffer
954 * Linux's stdio does not do that for fread()
964 got = fread(vbuf,1,count,s);
969 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
971 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
972 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
976 int ch = *buf-- & 0xff;
977 if (ungetc(ch,s) != ch)
986 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
988 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
992 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
994 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
995 return fseek(stdio,offset,whence);
999 PerlIOStdio_tell(PerlIO *f)
1001 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1002 return ftell(stdio);
1006 PerlIOStdio_close(PerlIO *f)
1008 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1012 PerlIOStdio_flush(PerlIO *f)
1014 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1015 return fflush(stdio);
1019 PerlIOStdio_eof(PerlIO *f)
1021 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1025 PerlIOStdio_error(PerlIO *f)
1027 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1031 PerlIOStdio_clearerr(PerlIO *f)
1033 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1037 PerlIOStdio_setlinebuf(PerlIO *f)
1039 #ifdef HAS_SETLINEBUF
1040 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1042 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1048 PerlIOStdio_get_base(PerlIO *f)
1050 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1051 return FILE_base(stdio);
1055 PerlIOStdio_get_bufsiz(PerlIO *f)
1057 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1058 return FILE_bufsiz(stdio);
1062 #ifdef USE_STDIO_PTR
1064 PerlIOStdio_get_ptr(PerlIO *f)
1066 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1067 return FILE_ptr(stdio);
1071 PerlIOStdio_get_cnt(PerlIO *f)
1073 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1074 return FILE_cnt(stdio);
1078 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1080 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1083 #ifdef STDIO_PTR_LVALUE
1084 FILE_ptr(stdio) = ptr;
1085 #ifdef STDIO_PTR_LVAL_SETS_CNT
1086 if (FILE_cnt(stdio) != (cnt))
1089 assert(FILE_cnt(stdio) == (cnt));
1092 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1093 /* Setting ptr _does_ change cnt - we are done */
1096 #else /* STDIO_PTR_LVALUE */
1098 #endif /* STDIO_PTR_LVALUE */
1100 /* Now (or only) set cnt */
1101 #ifdef STDIO_CNT_LVALUE
1102 FILE_cnt(stdio) = cnt;
1103 #else /* STDIO_CNT_LVALUE */
1104 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1105 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1106 #else /* STDIO_PTR_LVAL_SETS_CNT */
1108 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1109 #endif /* STDIO_CNT_LVALUE */
1114 PerlIO_funcs PerlIO_stdio = {
1116 sizeof(PerlIOStdio),
1131 PerlIOStdio_clearerr,
1132 PerlIOStdio_setlinebuf,
1134 PerlIOStdio_get_base,
1135 PerlIOStdio_get_bufsiz,
1140 #ifdef USE_STDIO_PTR
1141 PerlIOStdio_get_ptr,
1142 PerlIOStdio_get_cnt,
1143 #if (defined(STDIO_PTR_LVALUE) && \
1144 (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1145 PerlIOStdio_set_ptrcnt
1146 #else /* STDIO_PTR_LVALUE */
1148 #endif /* STDIO_PTR_LVALUE */
1149 #else /* USE_STDIO_PTR */
1153 #endif /* USE_STDIO_PTR */
1156 #undef PerlIO_exportFILE
1158 PerlIO_exportFILE(PerlIO *f, int fl)
1161 /* Should really push stdio discipline when we have them */
1162 return fdopen(PerlIO_fileno(f),"r+");
1165 #undef PerlIO_findFILE
1167 PerlIO_findFILE(PerlIO *f)
1169 return PerlIO_exportFILE(f,0);
1172 #undef PerlIO_releaseFILE
1174 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1178 /*--------------------------------------------------------------------------------------*/
1179 /* perlio buffer layer */
1183 struct _PerlIO base;
1184 Off_t posn; /* Offset of buf into the file */
1185 STDCHAR * buf; /* Start of buffer */
1186 STDCHAR * end; /* End of valid part of buffer */
1187 STDCHAR * ptr; /* Current position in buffer */
1188 Size_t bufsiz; /* Size of buffer */
1189 IV oneword; /* Emergency buffer */
1194 PerlIOBuf_fdopen(int fd, const char *mode)
1196 PerlIO_funcs *tab = PerlIO_default_btm();
1204 f = (*tab->Fdopen)(fd,mode);
1207 /* Initial stderr is unbuffered */
1208 if (!init || fd != 2)
1210 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1211 b->posn = PerlIO_tell(PerlIONext(f));
1218 PerlIOBuf_open(const char *path, const char *mode)
1220 PerlIO_funcs *tab = PerlIO_default_btm();
1221 PerlIO *f = (*tab->Open)(path,mode);
1224 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1231 PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1233 return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1237 PerlIOBuf_alloc_buf(PerlIOBuf *b)
1241 New('B',b->buf,b->bufsiz,STDCHAR);
1244 b->buf = (STDCHAR *)&b->oneword;
1245 b->bufsiz = sizeof(b->oneword);
1251 /* This "flush" is akin to sfio's sync in that it handles files in either
1255 PerlIOBuf_flush(PerlIO *f)
1257 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1259 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1261 /* write() the buffer */
1262 STDCHAR *p = b->buf;
1266 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1273 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1278 b->posn += (p - b->buf);
1280 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1282 /* Note position change */
1283 b->posn += (b->ptr - b->buf);
1284 if (b->ptr < b->end)
1286 /* We did not consume all of it */
1287 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1289 b->posn = PerlIO_tell(PerlIONext(f));
1293 b->ptr = b->end = b->buf;
1294 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1295 if (PerlIO_flush(PerlIONext(f)) != 0)
1301 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1303 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1304 STDCHAR *buf = (STDCHAR *) vbuf;
1309 PerlIOBuf_alloc_buf(b);
1310 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1314 SSize_t avail = (b->end - b->ptr);
1315 if ((SSize_t) count < avail)
1319 Copy(b->ptr,buf,avail,char);
1325 if (count && (b->ptr >= b->end))
1328 b->ptr = b->end = b->buf;
1329 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1333 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1335 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1338 b->end = b->buf+avail;
1339 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1348 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1350 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1351 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1355 PerlIOBuf_alloc_buf(b);
1356 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1360 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1362 avail = (b->ptr - b->buf);
1363 if (avail > (SSize_t) count)
1370 if (avail > (SSize_t) count)
1372 b->end = b->ptr + avail;
1379 Copy(buf,b->ptr,avail,char);
1383 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1390 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1392 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1393 const STDCHAR *buf = (const STDCHAR *) vbuf;
1396 PerlIOBuf_alloc_buf(b);
1397 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1401 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1402 if ((SSize_t) count < avail)
1404 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1405 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1425 Copy(buf,b->ptr,avail,char);
1432 if (b->ptr >= (b->buf + b->bufsiz))
1439 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1441 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1443 code = PerlIO_flush(f);
1446 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1447 code = PerlIO_seek(PerlIONext(f),offset,whence);
1450 b->posn = PerlIO_tell(PerlIONext(f));
1457 PerlIOBuf_tell(PerlIO *f)
1459 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1460 Off_t posn = b->posn;
1462 posn += (b->ptr - b->buf);
1467 PerlIOBuf_close(PerlIO *f)
1469 IV code = PerlIOBase_close(f);
1470 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1471 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1476 b->ptr = b->end = b->buf;
1477 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1482 PerlIOBuf_setlinebuf(PerlIO *f)
1486 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1491 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1493 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1496 PerlIOBuf_alloc_buf(b);
1497 b->ptr = b->end - cnt;
1498 assert(b->ptr >= b->buf);
1502 PerlIOBuf_get_ptr(PerlIO *f)
1504 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1506 PerlIOBuf_alloc_buf(b);
1511 PerlIOBuf_get_cnt(PerlIO *f)
1513 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1515 PerlIOBuf_alloc_buf(b);
1516 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1517 return (b->end - b->ptr);
1522 PerlIOBuf_get_base(PerlIO *f)
1524 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1526 PerlIOBuf_alloc_buf(b);
1531 PerlIOBuf_bufsiz(PerlIO *f)
1533 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1535 PerlIOBuf_alloc_buf(b);
1536 return (b->end - b->buf);
1540 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1542 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1544 PerlIOBuf_alloc_buf(b);
1546 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1549 assert(PerlIO_get_cnt(f) == cnt);
1550 assert(b->ptr >= b->buf);
1552 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1555 PerlIO_funcs PerlIO_perlio = {
1572 PerlIOBase_clearerr,
1573 PerlIOBuf_setlinebuf,
1578 PerlIOBuf_set_ptrcnt,
1586 atexit(&PerlIO_cleanup);
1587 PerlIO_fdopen(0,"Ir");
1588 PerlIO_fdopen(1,"Iw");
1589 PerlIO_fdopen(2,"Iw");
1602 #undef PerlIO_stdout
1611 #undef PerlIO_stderr
1620 /*--------------------------------------------------------------------------------------*/
1622 #undef PerlIO_getname
1624 PerlIO_getname(PerlIO *f, char *buf)
1627 Perl_croak(aTHX_ "Don't know how to get file name");
1632 /*--------------------------------------------------------------------------------------*/
1633 /* Functions which can be called on any kind of PerlIO implemented
1639 PerlIO_getc(PerlIO *f)
1642 int count = PerlIO_read(f,&buf,1);
1644 return (unsigned char) buf;
1650 PerlIO_putc(PerlIO *f, int ch)
1653 return PerlIO_write(f,&buf,1);
1658 PerlIO_puts(PerlIO *f, const char *s)
1660 STRLEN len = strlen(s);
1661 return PerlIO_write(f,s,len);
1664 #undef PerlIO_rewind
1666 PerlIO_rewind(PerlIO *f)
1668 PerlIO_seek(f,(Off_t)0,SEEK_SET);
1672 #undef PerlIO_vprintf
1674 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1677 SV *sv = newSVpvn("",0);
1680 sv_vcatpvf(sv, fmt, &ap);
1682 return PerlIO_write(f,s,len);
1685 #undef PerlIO_printf
1687 PerlIO_printf(PerlIO *f,const char *fmt,...)
1692 result = PerlIO_vprintf(f,fmt,ap);
1697 #undef PerlIO_stdoutf
1699 PerlIO_stdoutf(const char *fmt,...)
1704 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1709 #undef PerlIO_tmpfile
1711 PerlIO_tmpfile(void)
1714 /* I have no idea how portable mkstemp() is ... */
1715 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1716 int fd = mkstemp(SvPVX(sv));
1720 f = PerlIO_fdopen(fd,"w+");
1723 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
1734 #endif /* USE_SFIO */
1735 #endif /* PERLIO_IS_STDIO */
1737 /*======================================================================================*/
1738 /* Now some functions in terms of above which may be needed even if
1739 we are not in true PerlIO mode
1743 #undef PerlIO_setpos
1745 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1747 return PerlIO_seek(f,*pos,0);
1750 #ifndef PERLIO_IS_STDIO
1751 #undef PerlIO_setpos
1753 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1755 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1756 return fsetpos64(f, pos);
1758 return fsetpos(f, pos);
1765 #undef PerlIO_getpos
1767 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1769 *pos = PerlIO_tell(f);
1773 #ifndef PERLIO_IS_STDIO
1774 #undef PerlIO_getpos
1776 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1778 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1779 return fgetpos64(f, pos);
1781 return fgetpos(f, pos);
1787 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1790 vprintf(char *pat, char *args)
1792 _doprnt(pat, args, stdout);
1793 return 0; /* wrong, but perl doesn't use the return value */
1797 vfprintf(FILE *fd, char *pat, char *args)
1799 _doprnt(pat, args, fd);
1800 return 0; /* wrong, but perl doesn't use the return value */
1805 #ifndef PerlIO_vsprintf
1807 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1809 int val = vsprintf(s, fmt, ap);
1812 if (strlen(s) >= (STRLEN)n)
1815 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1823 #ifndef PerlIO_sprintf
1825 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1830 result = PerlIO_vsprintf(s, n, fmt, ap);
1836 #endif /* !PERL_IMPLICIT_SYS */