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_croak(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_ungetc(PerlIO *f, int ch)
521 if ((*PerlIOBase(f)->tab->Unread)(f,&buf,1) == 1)
528 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
530 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
535 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
537 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
542 PerlIO_tell(PerlIO *f)
544 return (*PerlIOBase(f)->tab->Tell)(f);
549 PerlIO_flush(PerlIO *f)
553 return (*PerlIOBase(f)->tab->Flush)(f);
557 PerlIO **table = &_perlio;
562 table = (PerlIO **)(f++);
563 for (i=1; i < PERLIO_TABLE_SIZE; i++)
565 if (*f && PerlIO_flush(f) != 0)
576 PerlIO_isutf8(PerlIO *f)
578 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
583 PerlIO_eof(PerlIO *f)
585 return (*PerlIOBase(f)->tab->Eof)(f);
590 PerlIO_error(PerlIO *f)
592 return (*PerlIOBase(f)->tab->Error)(f);
595 #undef PerlIO_clearerr
597 PerlIO_clearerr(PerlIO *f)
599 (*PerlIOBase(f)->tab->Clearerr)(f);
602 #undef PerlIO_setlinebuf
604 PerlIO_setlinebuf(PerlIO *f)
606 (*PerlIOBase(f)->tab->Setlinebuf)(f);
609 #undef PerlIO_has_base
611 PerlIO_has_base(PerlIO *f)
615 return (PerlIOBase(f)->tab->Get_base != NULL);
620 #undef PerlIO_fast_gets
622 PerlIO_fast_gets(PerlIO *f)
626 PerlIOl *l = PerlIOBase(f);
627 return (l->tab->Set_ptrcnt != NULL);
632 #undef PerlIO_has_cntptr
634 PerlIO_has_cntptr(PerlIO *f)
638 PerlIO_funcs *tab = PerlIOBase(f)->tab;
639 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
644 #undef PerlIO_canset_cnt
646 PerlIO_canset_cnt(PerlIO *f)
650 PerlIOl *l = PerlIOBase(f);
651 return (l->tab->Set_ptrcnt != NULL);
656 #undef PerlIO_get_base
658 PerlIO_get_base(PerlIO *f)
660 return (*PerlIOBase(f)->tab->Get_base)(f);
663 #undef PerlIO_get_bufsiz
665 PerlIO_get_bufsiz(PerlIO *f)
667 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
670 #undef PerlIO_get_ptr
672 PerlIO_get_ptr(PerlIO *f)
674 return (*PerlIOBase(f)->tab->Get_ptr)(f);
677 #undef PerlIO_get_cnt
679 PerlIO_get_cnt(PerlIO *f)
681 return (*PerlIOBase(f)->tab->Get_cnt)(f);
684 #undef PerlIO_set_cnt
686 PerlIO_set_cnt(PerlIO *f,int cnt)
688 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
691 #undef PerlIO_set_ptrcnt
693 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
695 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
698 /*--------------------------------------------------------------------------------------*/
699 /* "Methods" of the "base class" */
702 PerlIOBase_fileno(PerlIO *f)
704 return PerlIO_fileno(PerlIONext(f));
708 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
711 Newc('L',l,tab->size,char,PerlIOl);
714 Zero(l,tab->size,char);
718 PerlIOBase_init(f,mode);
724 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
726 Off_t old = PerlIO_tell(f);
727 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
729 Off_t new = PerlIO_tell(f);
736 PerlIOBase_sync(PerlIO *f)
742 PerlIOBase_close(PerlIO *f)
745 if (PerlIO_flush(f) != 0)
747 if (PerlIO_close(PerlIONext(f)) != 0)
749 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
754 PerlIOBase_eof(PerlIO *f)
758 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
764 PerlIOBase_error(PerlIO *f)
768 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
774 PerlIOBase_clearerr(PerlIO *f)
778 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
783 PerlIOBase_setlinebuf(PerlIO *f)
790 /*--------------------------------------------------------------------------------------*/
791 /* Bottom-most level for UNIX-like case */
795 struct _PerlIO base; /* The generic part */
796 int fd; /* UNIX like file descriptor */
797 int oflags; /* open/fcntl flags */
801 PerlIOUnix_oflags(const char *mode)
816 oflags = O_CREAT|O_TRUNC;
827 oflags = O_CREAT|O_APPEND;
837 if (*mode || oflags == -1)
846 PerlIOUnix_fileno(PerlIO *f)
848 return PerlIOSelf(f,PerlIOUnix)->fd;
852 PerlIOUnix_fdopen(int fd,const char *mode)
859 int oflags = PerlIOUnix_oflags(mode);
862 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
865 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
872 PerlIOUnix_open(const char *path,const char *mode)
875 int oflags = PerlIOUnix_oflags(mode);
878 int fd = open(path,oflags,0666);
881 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
884 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
891 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
893 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
894 int oflags = PerlIOUnix_oflags(mode);
895 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
896 (*PerlIOBase(f)->tab->Close)(f);
899 int fd = open(path,oflags,0666);
904 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
912 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
914 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
917 SSize_t len = read(fd,vbuf,count);
918 if (len >= 0 || errno != EINTR)
924 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
926 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
929 SSize_t len = write(fd,vbuf,count);
930 if (len >= 0 || errno != EINTR)
936 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
938 Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
939 return (new == (Off_t) -1) ? -1 : 0;
943 PerlIOUnix_tell(PerlIO *f)
945 return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
949 PerlIOUnix_close(PerlIO *f)
951 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
953 while (close(fd) != 0)
963 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
968 PerlIO_funcs PerlIO_unix = {
986 PerlIOBase_setlinebuf,
988 NULL, /* get_bufsiz */
991 NULL, /* set_ptrcnt */
994 /*--------------------------------------------------------------------------------------*/
995 /* stdio as a layer */
1000 FILE * stdio; /* The stream */
1004 PerlIOStdio_fileno(PerlIO *f)
1006 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1011 PerlIOStdio_fdopen(int fd,const char *mode)
1039 stdio = fdopen(fd,mode);
1042 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1049 #undef PerlIO_importFILE
1051 PerlIO_importFILE(FILE *stdio, int fl)
1056 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1063 PerlIOStdio_open(const char *path,const char *mode)
1066 FILE *stdio = fopen(path,mode);
1069 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1076 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1078 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1079 FILE *stdio = freopen(path,mode,s->stdio);
1087 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1089 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1093 STDCHAR *buf = (STDCHAR *) vbuf;
1094 /* Perl is expecting PerlIO_getc() to fill the buffer
1095 * Linux's stdio does not do that for fread()
1105 got = fread(vbuf,1,count,s);
1110 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1112 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1113 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1117 int ch = *buf-- & 0xff;
1118 if (ungetc(ch,s) != ch)
1127 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1129 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1133 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1135 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1136 return fseek(stdio,offset,whence);
1140 PerlIOStdio_tell(PerlIO *f)
1142 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1143 return ftell(stdio);
1147 PerlIOStdio_close(PerlIO *f)
1149 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1153 PerlIOStdio_flush(PerlIO *f)
1155 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1156 return fflush(stdio);
1160 PerlIOStdio_eof(PerlIO *f)
1162 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1166 PerlIOStdio_error(PerlIO *f)
1168 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1172 PerlIOStdio_clearerr(PerlIO *f)
1174 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1178 PerlIOStdio_setlinebuf(PerlIO *f)
1180 #ifdef HAS_SETLINEBUF
1181 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1183 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1189 PerlIOStdio_get_base(PerlIO *f)
1191 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1192 return FILE_base(stdio);
1196 PerlIOStdio_get_bufsiz(PerlIO *f)
1198 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1199 return FILE_bufsiz(stdio);
1203 #ifdef USE_STDIO_PTR
1205 PerlIOStdio_get_ptr(PerlIO *f)
1207 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1208 return FILE_ptr(stdio);
1212 PerlIOStdio_get_cnt(PerlIO *f)
1214 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1215 return FILE_cnt(stdio);
1219 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1221 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1224 #ifdef STDIO_PTR_LVALUE
1225 FILE_ptr(stdio) = ptr;
1226 #ifdef STDIO_PTR_LVAL_SETS_CNT
1227 if (FILE_cnt(stdio) != (cnt))
1230 assert(FILE_cnt(stdio) == (cnt));
1233 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1234 /* Setting ptr _does_ change cnt - we are done */
1237 #else /* STDIO_PTR_LVALUE */
1239 #endif /* STDIO_PTR_LVALUE */
1241 /* Now (or only) set cnt */
1242 #ifdef STDIO_CNT_LVALUE
1243 FILE_cnt(stdio) = cnt;
1244 #else /* STDIO_CNT_LVALUE */
1245 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1246 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1247 #else /* STDIO_PTR_LVAL_SETS_CNT */
1249 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1250 #endif /* STDIO_CNT_LVALUE */
1255 PerlIO_funcs PerlIO_stdio = {
1257 sizeof(PerlIOStdio),
1272 PerlIOStdio_clearerr,
1273 PerlIOStdio_setlinebuf,
1275 PerlIOStdio_get_base,
1276 PerlIOStdio_get_bufsiz,
1281 #ifdef USE_STDIO_PTR
1282 PerlIOStdio_get_ptr,
1283 PerlIOStdio_get_cnt,
1284 #if (defined(STDIO_PTR_LVALUE) && (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 int count = PerlIO_read(f,&buf,1);
1781 return (unsigned char) buf;
1787 PerlIO_putc(PerlIO *f, int ch)
1790 return PerlIO_write(f,&buf,1);
1795 PerlIO_puts(PerlIO *f, const char *s)
1797 STRLEN len = strlen(s);
1798 return PerlIO_write(f,s,len);
1801 #undef PerlIO_rewind
1803 PerlIO_rewind(PerlIO *f)
1805 PerlIO_seek(f,(Off_t)0,SEEK_SET);
1809 #undef PerlIO_vprintf
1811 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1814 SV *sv = newSVpvn("",0);
1817 sv_vcatpvf(sv, fmt, &ap);
1819 return PerlIO_write(f,s,len);
1822 #undef PerlIO_printf
1824 PerlIO_printf(PerlIO *f,const char *fmt,...)
1829 result = PerlIO_vprintf(f,fmt,ap);
1834 #undef PerlIO_stdoutf
1836 PerlIO_stdoutf(const char *fmt,...)
1841 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1846 #undef PerlIO_tmpfile
1848 PerlIO_tmpfile(void)
1851 /* I have no idea how portable mkstemp() is ... */
1852 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1853 int fd = mkstemp(SvPVX(sv));
1857 f = PerlIO_fdopen(fd,"w+");
1860 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
1871 #endif /* USE_SFIO */
1872 #endif /* PERLIO_IS_STDIO */
1874 /*======================================================================================*/
1875 /* Now some functions in terms of above which may be needed even if
1876 we are not in true PerlIO mode
1880 #undef PerlIO_setpos
1882 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1884 return PerlIO_seek(f,*pos,0);
1887 #ifndef PERLIO_IS_STDIO
1888 #undef PerlIO_setpos
1890 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1892 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1893 return fsetpos64(f, pos);
1895 return fsetpos(f, pos);
1902 #undef PerlIO_getpos
1904 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1906 *pos = PerlIO_tell(f);
1910 #ifndef PERLIO_IS_STDIO
1911 #undef PerlIO_getpos
1913 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1915 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1916 return fgetpos64(f, pos);
1918 return fgetpos(f, pos);
1924 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1927 vprintf(char *pat, char *args)
1929 _doprnt(pat, args, stdout);
1930 return 0; /* wrong, but perl doesn't use the return value */
1934 vfprintf(FILE *fd, char *pat, char *args)
1936 _doprnt(pat, args, fd);
1937 return 0; /* wrong, but perl doesn't use the return value */
1942 #ifndef PerlIO_vsprintf
1944 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1946 int val = vsprintf(s, fmt, ap);
1949 if (strlen(s) >= (STRLEN)n)
1952 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1960 #ifndef PerlIO_sprintf
1962 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1967 result = PerlIO_vsprintf(s, n, fmt, ap);
1973 #endif /* !PERL_IMPLICIT_SYS */