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 */
98 void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
101 PerlIO_debug(char *fmt,...)
106 char *s = getenv("PERLIO_DEBUG");
108 dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
116 SV *sv = newSVpvn("",0);
120 s = CopFILE(PL_curcop);
123 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
124 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
133 /*--------------------------------------------------------------------------------------*/
140 IV (*Fileno)(PerlIO *f);
141 PerlIO * (*Fdopen)(int fd, const char *mode);
142 PerlIO * (*Open)(const char *path, const char *mode);
143 int (*Reopen)(const char *path, const char *mode, PerlIO *f);
144 /* Unix-like functions - cf sfio line disciplines */
145 SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
146 SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
147 SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
148 IV (*Seek)(PerlIO *f, Off_t offset, int whence);
149 Off_t (*Tell)(PerlIO *f);
150 IV (*Close)(PerlIO *f);
151 /* Stdio-like buffered IO functions */
152 IV (*Flush)(PerlIO *f);
153 IV (*Eof)(PerlIO *f);
154 IV (*Error)(PerlIO *f);
155 void (*Clearerr)(PerlIO *f);
156 void (*Setlinebuf)(PerlIO *f);
157 /* Perl's snooping functions */
158 STDCHAR * (*Get_base)(PerlIO *f);
159 Size_t (*Get_bufsiz)(PerlIO *f);
160 STDCHAR * (*Get_ptr)(PerlIO *f);
161 SSize_t (*Get_cnt)(PerlIO *f);
162 void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
168 PerlIOl * next; /* Lower layer */
169 PerlIO_funcs * tab; /* Functions for this layer */
170 IV flags; /* Various flags for state */
173 /*--------------------------------------------------------------------------------------*/
176 #define PERLIO_F_EOF 0x00010000
177 #define PERLIO_F_CANWRITE 0x00020000
178 #define PERLIO_F_CANREAD 0x00040000
179 #define PERLIO_F_ERROR 0x00080000
180 #define PERLIO_F_TRUNCATE 0x00100000
181 #define PERLIO_F_APPEND 0x00200000
182 #define PERLIO_F_BINARY 0x00400000
183 #define PERLIO_F_UTF8 0x00800000
184 #define PERLIO_F_LINEBUF 0x01000000
185 #define PERLIO_F_WRBUF 0x02000000
186 #define PERLIO_F_RDBUF 0x04000000
187 #define PERLIO_F_TEMP 0x08000000
188 #define PERLIO_F_OPEN 0x10000000
190 #define PerlIOBase(f) (*(f))
191 #define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
192 #define PerlIONext(f) (&(PerlIOBase(f)->next))
194 /*--------------------------------------------------------------------------------------*/
195 /* Inner level routines */
197 /* Table of pointers to the PerlIO structs (malloc'ed) */
198 PerlIO *_perlio = NULL;
199 #define PERLIO_TABLE_SIZE 64
202 PerlIO_allocate(void)
204 /* Find a free slot in the table, allocating new table as necessary */
205 PerlIO **last = &_perlio;
210 last = (PerlIO **)(f);
211 for (i=1; i < PERLIO_TABLE_SIZE; i++)
219 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
227 PerlIO_cleantable(PerlIO **tablep)
229 PerlIO *table = *tablep;
233 PerlIO_cleantable((PerlIO **) &(table[0]));
234 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
248 PerlIO_cleantable(&_perlio);
252 PerlIO_pop(PerlIO *f)
264 PerlIO_close(PerlIO *f)
266 int code = (*PerlIOBase(f)->tab->Close)(f);
275 /*--------------------------------------------------------------------------------------*/
276 /* Given the abstraction above the public API functions */
280 PerlIO_fileno(PerlIO *f)
282 return (*PerlIOBase(f)->tab->Fileno)(f);
286 extern PerlIO_funcs PerlIO_unix;
287 extern PerlIO_funcs PerlIO_perlio;
288 extern PerlIO_funcs PerlIO_stdio;
294 char *s = GvNAME(gv);
295 STRLEN l = GvNAMELEN(gv);
296 PerlIO_debug("%.*s\n",(int) l,s);
300 XS(XS_perlio_unimport)
304 char *s = GvNAME(gv);
305 STRLEN l = GvNAMELEN(gv);
306 PerlIO_debug("%.*s\n",(int) l,s);
314 PerlIO_find_layer(char *name, STRLEN len)
321 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
322 if (svp && (sv = *svp) && SvROK(sv))
328 PerlIO_define_layer(PerlIO_funcs *tab)
331 HV *stash = gv_stashpv("perlio::Layer", TRUE);
332 SV *sv = sv_bless(newRV_noinc(newSViv((IV) tab)),stash);
333 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
337 PerlIO_default_layer(I32 n)
342 PerlIO_funcs *tab = &PerlIO_stdio;
344 if (!PerlIO_layer_hv)
346 char *s = getenv("PERLIO");
347 newXS("perlio::import",XS_perlio_import,__FILE__);
348 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
349 PerlIO_layer_hv = get_hv("perlio::layers",GV_ADD|GV_ADDMULTI);
350 PerlIO_layer_av = get_av("perlio::layers",GV_ADD|GV_ADDMULTI);
351 PerlIO_define_layer(&PerlIO_unix);
352 PerlIO_define_layer(&PerlIO_unix);
353 PerlIO_define_layer(&PerlIO_perlio);
354 PerlIO_define_layer(&PerlIO_stdio);
355 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
360 while (*s && isspace((unsigned char)*s))
366 while (*e && !isspace((unsigned char)*e))
368 layer = PerlIO_find_layer(s,e-s);
371 PerlIO_debug("Pushing %.*s\n",(e-s),s);
372 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
375 Perl_warn(aTHX_ "Unknown layer %.*s",(e-s),s);
381 len = av_len(PerlIO_layer_av);
384 if (PerlIO_stdio.Set_ptrcnt)
386 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
390 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
392 len = av_len(PerlIO_layer_av);
396 svp = av_fetch(PerlIO_layer_av,n,0);
397 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
399 tab = (PerlIO_funcs *) SvIV(layer);
401 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
405 #define PerlIO_default_top() PerlIO_default_layer(-1)
406 #define PerlIO_default_btm() PerlIO_default_layer(0)
414 PerlIO_fdopen(0,"Ir");
415 PerlIO_fdopen(1,"Iw");
416 PerlIO_fdopen(2,"Iw");
422 PerlIO_fdopen(int fd, const char *mode)
424 PerlIO_funcs *tab = PerlIO_default_top();
427 return (*tab->Fdopen)(fd,mode);
432 PerlIO_open(const char *path, const char *mode)
434 PerlIO_funcs *tab = PerlIO_default_top();
437 return (*tab->Open)(path,mode);
441 PerlIOBase_init(PerlIO *f, const char *mode)
443 PerlIOl *l = PerlIOBase(f);
444 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
445 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
451 l->flags = PERLIO_F_CANREAD;
454 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
457 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
468 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
471 l->flags |= PERLIO_F_BINARY;
483 l->flags |= l->next->flags &
484 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
485 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
493 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
498 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
500 PerlIOBase_init(f,mode);
506 return PerlIO_open(path,mode);
511 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
513 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
518 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
520 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
525 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
527 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
532 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
534 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
539 PerlIO_tell(PerlIO *f)
541 return (*PerlIOBase(f)->tab->Tell)(f);
546 PerlIO_flush(PerlIO *f)
550 return (*PerlIOBase(f)->tab->Flush)(f);
554 PerlIO **table = &_perlio;
559 table = (PerlIO **)(f++);
560 for (i=1; i < PERLIO_TABLE_SIZE; i++)
562 if (*f && PerlIO_flush(f) != 0)
573 PerlIO_isutf8(PerlIO *f)
575 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
580 PerlIO_eof(PerlIO *f)
582 return (*PerlIOBase(f)->tab->Eof)(f);
587 PerlIO_error(PerlIO *f)
589 return (*PerlIOBase(f)->tab->Error)(f);
592 #undef PerlIO_clearerr
594 PerlIO_clearerr(PerlIO *f)
596 (*PerlIOBase(f)->tab->Clearerr)(f);
599 #undef PerlIO_setlinebuf
601 PerlIO_setlinebuf(PerlIO *f)
603 (*PerlIOBase(f)->tab->Setlinebuf)(f);
606 #undef PerlIO_has_base
608 PerlIO_has_base(PerlIO *f)
612 return (PerlIOBase(f)->tab->Get_base != NULL);
617 #undef PerlIO_fast_gets
619 PerlIO_fast_gets(PerlIO *f)
623 PerlIOl *l = PerlIOBase(f);
624 return (l->tab->Set_ptrcnt != NULL);
629 #undef PerlIO_has_cntptr
631 PerlIO_has_cntptr(PerlIO *f)
635 PerlIO_funcs *tab = PerlIOBase(f)->tab;
636 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
641 #undef PerlIO_canset_cnt
643 PerlIO_canset_cnt(PerlIO *f)
647 PerlIOl *l = PerlIOBase(f);
648 return (l->tab->Set_ptrcnt != NULL);
653 #undef PerlIO_get_base
655 PerlIO_get_base(PerlIO *f)
657 return (*PerlIOBase(f)->tab->Get_base)(f);
660 #undef PerlIO_get_bufsiz
662 PerlIO_get_bufsiz(PerlIO *f)
664 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
667 #undef PerlIO_get_ptr
669 PerlIO_get_ptr(PerlIO *f)
671 return (*PerlIOBase(f)->tab->Get_ptr)(f);
674 #undef PerlIO_get_cnt
676 PerlIO_get_cnt(PerlIO *f)
678 return (*PerlIOBase(f)->tab->Get_cnt)(f);
681 #undef PerlIO_set_cnt
683 PerlIO_set_cnt(PerlIO *f,int cnt)
685 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
688 #undef PerlIO_set_ptrcnt
690 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
692 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
695 /*--------------------------------------------------------------------------------------*/
696 /* "Methods" of the "base class" */
699 PerlIOBase_fileno(PerlIO *f)
701 return PerlIO_fileno(PerlIONext(f));
705 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
708 Newc('L',l,tab->size,char,PerlIOl);
711 Zero(l,tab->size,char);
715 PerlIOBase_init(f,mode);
721 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
723 Off_t old = PerlIO_tell(f);
724 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
726 Off_t new = PerlIO_tell(f);
733 PerlIOBase_sync(PerlIO *f)
739 PerlIOBase_close(PerlIO *f)
742 if (PerlIO_flush(f) != 0)
744 if (PerlIO_close(PerlIONext(f)) != 0)
746 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
751 PerlIOBase_eof(PerlIO *f)
755 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
761 PerlIOBase_error(PerlIO *f)
765 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
771 PerlIOBase_clearerr(PerlIO *f)
775 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
780 PerlIOBase_setlinebuf(PerlIO *f)
787 /*--------------------------------------------------------------------------------------*/
788 /* Bottom-most level for UNIX-like case */
792 struct _PerlIO base; /* The generic part */
793 int fd; /* UNIX like file descriptor */
794 int oflags; /* open/fcntl flags */
798 PerlIOUnix_oflags(const char *mode)
813 oflags = O_CREAT|O_TRUNC;
824 oflags = O_CREAT|O_APPEND;
834 if (*mode || oflags == -1)
843 PerlIOUnix_fileno(PerlIO *f)
845 return PerlIOSelf(f,PerlIOUnix)->fd;
849 PerlIOUnix_fdopen(int fd,const char *mode)
856 int oflags = PerlIOUnix_oflags(mode);
859 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
862 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
869 PerlIOUnix_open(const char *path,const char *mode)
872 int oflags = PerlIOUnix_oflags(mode);
875 int fd = open(path,oflags,0666);
878 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
881 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
888 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
890 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
891 int oflags = PerlIOUnix_oflags(mode);
892 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
893 (*PerlIOBase(f)->tab->Close)(f);
896 int fd = open(path,oflags,0666);
901 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
909 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
911 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
912 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
916 SSize_t len = read(fd,vbuf,count);
917 if (len >= 0 || errno != EINTR)
923 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
925 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
928 SSize_t len = write(fd,vbuf,count);
929 if (len >= 0 || errno != EINTR)
935 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
937 Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
938 return (new == (Off_t) -1) ? -1 : 0;
942 PerlIOUnix_tell(PerlIO *f)
944 return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
948 PerlIOUnix_close(PerlIO *f)
950 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
952 while (close(fd) != 0)
962 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
967 PerlIO_funcs PerlIO_unix = {
985 PerlIOBase_setlinebuf,
987 NULL, /* get_bufsiz */
990 NULL, /* set_ptrcnt */
993 /*--------------------------------------------------------------------------------------*/
994 /* stdio as a layer */
999 FILE * stdio; /* The stream */
1003 PerlIOStdio_fileno(PerlIO *f)
1005 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1010 PerlIOStdio_fdopen(int fd,const char *mode)
1038 stdio = fdopen(fd,mode);
1041 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1048 #undef PerlIO_importFILE
1050 PerlIO_importFILE(FILE *stdio, int fl)
1055 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1062 PerlIOStdio_open(const char *path,const char *mode)
1065 FILE *stdio = fopen(path,mode);
1068 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1075 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1077 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1078 FILE *stdio = freopen(path,mode,s->stdio);
1086 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1088 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1092 STDCHAR *buf = (STDCHAR *) vbuf;
1093 /* Perl is expecting PerlIO_getc() to fill the buffer
1094 * Linux's stdio does not do that for fread()
1104 got = fread(vbuf,1,count,s);
1109 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1111 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1112 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1116 int ch = *buf-- & 0xff;
1117 if (ungetc(ch,s) != ch)
1126 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1128 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1132 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1134 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1135 return fseek(stdio,offset,whence);
1139 PerlIOStdio_tell(PerlIO *f)
1141 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1142 return ftell(stdio);
1146 PerlIOStdio_close(PerlIO *f)
1148 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1152 PerlIOStdio_flush(PerlIO *f)
1154 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1155 return fflush(stdio);
1159 PerlIOStdio_eof(PerlIO *f)
1161 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1165 PerlIOStdio_error(PerlIO *f)
1167 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1171 PerlIOStdio_clearerr(PerlIO *f)
1173 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1177 PerlIOStdio_setlinebuf(PerlIO *f)
1179 #ifdef HAS_SETLINEBUF
1180 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1182 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1188 PerlIOStdio_get_base(PerlIO *f)
1190 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1191 return FILE_base(stdio);
1195 PerlIOStdio_get_bufsiz(PerlIO *f)
1197 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1198 return FILE_bufsiz(stdio);
1202 #ifdef USE_STDIO_PTR
1204 PerlIOStdio_get_ptr(PerlIO *f)
1206 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1207 return FILE_ptr(stdio);
1211 PerlIOStdio_get_cnt(PerlIO *f)
1213 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1214 return FILE_cnt(stdio);
1218 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1220 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1223 #ifdef STDIO_PTR_LVALUE
1224 FILE_ptr(stdio) = ptr;
1225 #ifdef STDIO_PTR_LVAL_SETS_CNT
1226 if (FILE_cnt(stdio) != (cnt))
1229 assert(FILE_cnt(stdio) == (cnt));
1232 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1233 /* Setting ptr _does_ change cnt - we are done */
1236 #else /* STDIO_PTR_LVALUE */
1238 #endif /* STDIO_PTR_LVALUE */
1240 /* Now (or only) set cnt */
1241 #ifdef STDIO_CNT_LVALUE
1242 FILE_cnt(stdio) = cnt;
1243 #else /* STDIO_CNT_LVALUE */
1244 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1245 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1246 #else /* STDIO_PTR_LVAL_SETS_CNT */
1248 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1249 #endif /* STDIO_CNT_LVALUE */
1254 PerlIO_funcs PerlIO_stdio = {
1256 sizeof(PerlIOStdio),
1271 PerlIOStdio_clearerr,
1272 PerlIOStdio_setlinebuf,
1274 PerlIOStdio_get_base,
1275 PerlIOStdio_get_bufsiz,
1280 #ifdef USE_STDIO_PTR
1281 PerlIOStdio_get_ptr,
1282 PerlIOStdio_get_cnt,
1283 #if (defined(STDIO_PTR_LVALUE) && \
1284 (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1285 PerlIOStdio_set_ptrcnt
1286 #else /* STDIO_PTR_LVALUE */
1288 #endif /* STDIO_PTR_LVALUE */
1289 #else /* USE_STDIO_PTR */
1293 #endif /* USE_STDIO_PTR */
1296 #undef PerlIO_exportFILE
1298 PerlIO_exportFILE(PerlIO *f, int fl)
1301 /* Should really push stdio discipline when we have them */
1302 return fdopen(PerlIO_fileno(f),"r+");
1305 #undef PerlIO_findFILE
1307 PerlIO_findFILE(PerlIO *f)
1309 return PerlIO_exportFILE(f,0);
1312 #undef PerlIO_releaseFILE
1314 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1318 /*--------------------------------------------------------------------------------------*/
1319 /* perlio buffer layer */
1323 struct _PerlIO base;
1324 Off_t posn; /* Offset of buf into the file */
1325 STDCHAR * buf; /* Start of buffer */
1326 STDCHAR * end; /* End of valid part of buffer */
1327 STDCHAR * ptr; /* Current position in buffer */
1328 Size_t bufsiz; /* Size of buffer */
1329 IV oneword; /* Emergency buffer */
1334 PerlIOBuf_fdopen(int fd, const char *mode)
1336 PerlIO_funcs *tab = PerlIO_default_btm();
1344 f = (*tab->Fdopen)(fd,mode);
1347 /* Initial stderr is unbuffered */
1348 if (!init || fd != 2)
1350 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1351 b->posn = PerlIO_tell(PerlIONext(f));
1358 PerlIOBuf_open(const char *path, const char *mode)
1360 PerlIO_funcs *tab = PerlIO_default_btm();
1361 PerlIO *f = (*tab->Open)(path,mode);
1364 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1371 PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1373 return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1377 PerlIOBuf_alloc_buf(PerlIOBuf *b)
1381 New('B',b->buf,b->bufsiz,STDCHAR);
1384 b->buf = (STDCHAR *)&b->oneword;
1385 b->bufsiz = sizeof(b->oneword);
1391 /* This "flush" is akin to sfio's sync in that it handles files in either
1395 PerlIOBuf_flush(PerlIO *f)
1397 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1399 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1401 /* write() the buffer */
1402 STDCHAR *p = b->buf;
1406 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1413 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1418 b->posn += (p - b->buf);
1420 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1422 /* Note position change */
1423 b->posn += (b->ptr - b->buf);
1424 if (b->ptr < b->end)
1426 /* We did not consume all of it */
1427 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1429 b->posn = PerlIO_tell(PerlIONext(f));
1433 b->ptr = b->end = b->buf;
1434 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1435 if (PerlIO_flush(PerlIONext(f)) != 0)
1441 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1443 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1444 STDCHAR *buf = (STDCHAR *) vbuf;
1449 PerlIOBuf_alloc_buf(b);
1450 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1454 SSize_t avail = (b->end - b->ptr);
1455 if ((SSize_t) count < avail)
1459 Copy(b->ptr,buf,avail,char);
1465 if (count && (b->ptr >= b->end))
1468 b->ptr = b->end = b->buf;
1469 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1473 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1475 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1478 b->end = b->buf+avail;
1479 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1488 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1490 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1491 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1495 PerlIOBuf_alloc_buf(b);
1496 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1500 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1502 avail = (b->ptr - b->buf);
1503 if (avail > (SSize_t) count)
1510 if (avail > (SSize_t) count)
1512 b->end = b->ptr + avail;
1519 Copy(buf,b->ptr,avail,char);
1523 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1530 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1532 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1533 const STDCHAR *buf = (const STDCHAR *) vbuf;
1536 PerlIOBuf_alloc_buf(b);
1537 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1541 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1542 if ((SSize_t) count < avail)
1544 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1545 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1565 Copy(buf,b->ptr,avail,char);
1572 if (b->ptr >= (b->buf + b->bufsiz))
1579 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1581 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1583 code = PerlIO_flush(f);
1586 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1587 code = PerlIO_seek(PerlIONext(f),offset,whence);
1590 b->posn = PerlIO_tell(PerlIONext(f));
1597 PerlIOBuf_tell(PerlIO *f)
1599 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1600 Off_t posn = b->posn;
1602 posn += (b->ptr - b->buf);
1607 PerlIOBuf_close(PerlIO *f)
1609 IV code = PerlIOBase_close(f);
1610 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1611 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1616 b->ptr = b->end = b->buf;
1617 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1622 PerlIOBuf_setlinebuf(PerlIO *f)
1626 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1631 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1633 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1636 PerlIOBuf_alloc_buf(b);
1637 b->ptr = b->end - cnt;
1638 assert(b->ptr >= b->buf);
1642 PerlIOBuf_get_ptr(PerlIO *f)
1644 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1646 PerlIOBuf_alloc_buf(b);
1651 PerlIOBuf_get_cnt(PerlIO *f)
1653 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1655 PerlIOBuf_alloc_buf(b);
1656 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1657 return (b->end - b->ptr);
1662 PerlIOBuf_get_base(PerlIO *f)
1664 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1666 PerlIOBuf_alloc_buf(b);
1671 PerlIOBuf_bufsiz(PerlIO *f)
1673 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1675 PerlIOBuf_alloc_buf(b);
1676 return (b->end - b->buf);
1680 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1682 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1684 PerlIOBuf_alloc_buf(b);
1686 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1689 assert(PerlIO_get_cnt(f) == cnt);
1690 assert(b->ptr >= b->buf);
1692 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1695 PerlIO_funcs PerlIO_perlio = {
1712 PerlIOBase_clearerr,
1713 PerlIOBuf_setlinebuf,
1718 PerlIOBuf_set_ptrcnt,
1726 atexit(&PerlIO_cleanup);
1735 PerlIO_stdstreams();
1739 #undef PerlIO_stdout
1744 PerlIO_stdstreams();
1748 #undef PerlIO_stderr
1753 PerlIO_stdstreams();
1757 /*--------------------------------------------------------------------------------------*/
1759 #undef PerlIO_getname
1761 PerlIO_getname(PerlIO *f, char *buf)
1764 Perl_croak(aTHX_ "Don't know how to get file name");
1769 /*--------------------------------------------------------------------------------------*/
1770 /* Functions which can be called on any kind of PerlIO implemented
1776 PerlIO_getc(PerlIO *f)
1779 SSize_t count = PerlIO_read(f,buf,1);
1782 return (unsigned char) buf[0];
1787 #undef PerlIO_ungetc
1789 PerlIO_ungetc(PerlIO *f, int ch)
1794 if (PerlIO_unread(f,&buf,1) == 1)
1802 PerlIO_putc(PerlIO *f, int ch)
1805 return PerlIO_write(f,&buf,1);
1810 PerlIO_puts(PerlIO *f, const char *s)
1812 STRLEN len = strlen(s);
1813 return PerlIO_write(f,s,len);
1816 #undef PerlIO_rewind
1818 PerlIO_rewind(PerlIO *f)
1820 PerlIO_seek(f,(Off_t)0,SEEK_SET);
1824 #undef PerlIO_vprintf
1826 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1829 SV *sv = newSVpvn("",0);
1832 sv_vcatpvf(sv, fmt, &ap);
1834 return PerlIO_write(f,s,len);
1837 #undef PerlIO_printf
1839 PerlIO_printf(PerlIO *f,const char *fmt,...)
1844 result = PerlIO_vprintf(f,fmt,ap);
1849 #undef PerlIO_stdoutf
1851 PerlIO_stdoutf(const char *fmt,...)
1856 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1861 #undef PerlIO_tmpfile
1863 PerlIO_tmpfile(void)
1866 /* I have no idea how portable mkstemp() is ... */
1867 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1868 int fd = mkstemp(SvPVX(sv));
1872 f = PerlIO_fdopen(fd,"w+");
1875 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
1886 #endif /* USE_SFIO */
1887 #endif /* PERLIO_IS_STDIO */
1889 /*======================================================================================*/
1890 /* Now some functions in terms of above which may be needed even if
1891 we are not in true PerlIO mode
1895 #undef PerlIO_setpos
1897 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1899 return PerlIO_seek(f,*pos,0);
1902 #ifndef PERLIO_IS_STDIO
1903 #undef PerlIO_setpos
1905 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1907 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1908 return fsetpos64(f, pos);
1910 return fsetpos(f, pos);
1917 #undef PerlIO_getpos
1919 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1921 *pos = PerlIO_tell(f);
1925 #ifndef PERLIO_IS_STDIO
1926 #undef PerlIO_getpos
1928 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1930 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1931 return fgetpos64(f, pos);
1933 return fgetpos(f, pos);
1939 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1942 vprintf(char *pat, char *args)
1944 _doprnt(pat, args, stdout);
1945 return 0; /* wrong, but perl doesn't use the return value */
1949 vfprintf(FILE *fd, char *pat, char *args)
1951 _doprnt(pat, args, fd);
1952 return 0; /* wrong, but perl doesn't use the return value */
1957 #ifndef PerlIO_vsprintf
1959 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1961 int val = vsprintf(s, fmt, ap);
1964 if (strlen(s) >= (STRLEN)n)
1967 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1975 #ifndef PerlIO_sprintf
1977 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1982 result = PerlIO_vsprintf(s, n, fmt, ap);
1988 #endif /* !PERL_IMPLICIT_SYS */