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) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1284 PerlIOStdio_set_ptrcnt
1285 #else /* STDIO_PTR_LVALUE */
1287 #endif /* STDIO_PTR_LVALUE */
1288 #else /* USE_STDIO_PTR */
1292 #endif /* USE_STDIO_PTR */
1295 #undef PerlIO_exportFILE
1297 PerlIO_exportFILE(PerlIO *f, int fl)
1300 /* Should really push stdio discipline when we have them */
1301 return fdopen(PerlIO_fileno(f),"r+");
1304 #undef PerlIO_findFILE
1306 PerlIO_findFILE(PerlIO *f)
1308 return PerlIO_exportFILE(f,0);
1311 #undef PerlIO_releaseFILE
1313 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1317 /*--------------------------------------------------------------------------------------*/
1318 /* perlio buffer layer */
1322 struct _PerlIO base;
1323 Off_t posn; /* Offset of buf into the file */
1324 STDCHAR * buf; /* Start of buffer */
1325 STDCHAR * end; /* End of valid part of buffer */
1326 STDCHAR * ptr; /* Current position in buffer */
1327 Size_t bufsiz; /* Size of buffer */
1328 IV oneword; /* Emergency buffer */
1333 PerlIOBuf_fdopen(int fd, const char *mode)
1335 PerlIO_funcs *tab = PerlIO_default_btm();
1343 f = (*tab->Fdopen)(fd,mode);
1346 /* Initial stderr is unbuffered */
1347 if (!init || fd != 2)
1349 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1350 b->posn = PerlIO_tell(PerlIONext(f));
1357 PerlIOBuf_open(const char *path, const char *mode)
1359 PerlIO_funcs *tab = PerlIO_default_btm();
1360 PerlIO *f = (*tab->Open)(path,mode);
1363 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1370 PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1372 return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1376 PerlIOBuf_alloc_buf(PerlIOBuf *b)
1380 New('B',b->buf,b->bufsiz,STDCHAR);
1383 b->buf = (STDCHAR *)&b->oneword;
1384 b->bufsiz = sizeof(b->oneword);
1390 /* This "flush" is akin to sfio's sync in that it handles files in either
1394 PerlIOBuf_flush(PerlIO *f)
1396 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1398 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1400 /* write() the buffer */
1401 STDCHAR *p = b->buf;
1405 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1412 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1417 b->posn += (p - b->buf);
1419 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1421 /* Note position change */
1422 b->posn += (b->ptr - b->buf);
1423 if (b->ptr < b->end)
1425 /* We did not consume all of it */
1426 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1428 b->posn = PerlIO_tell(PerlIONext(f));
1432 b->ptr = b->end = b->buf;
1433 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1434 if (PerlIO_flush(PerlIONext(f)) != 0)
1440 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1442 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1443 STDCHAR *buf = (STDCHAR *) vbuf;
1448 PerlIOBuf_alloc_buf(b);
1449 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1453 SSize_t avail = (b->end - b->ptr);
1454 if ((SSize_t) count < avail)
1458 Copy(b->ptr,buf,avail,char);
1464 if (count && (b->ptr >= b->end))
1467 b->ptr = b->end = b->buf;
1468 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1472 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1474 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1477 b->end = b->buf+avail;
1478 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1487 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1489 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1490 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1494 PerlIOBuf_alloc_buf(b);
1495 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1499 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1501 avail = (b->ptr - b->buf);
1502 if (avail > (SSize_t) count)
1509 if (avail > (SSize_t) count)
1511 b->end = b->ptr + avail;
1518 Copy(buf,b->ptr,avail,char);
1522 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1529 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1531 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1532 const STDCHAR *buf = (const STDCHAR *) vbuf;
1535 PerlIOBuf_alloc_buf(b);
1536 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1540 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1541 if ((SSize_t) count < avail)
1543 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1544 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1564 Copy(buf,b->ptr,avail,char);
1571 if (b->ptr >= (b->buf + b->bufsiz))
1578 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1580 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1582 code = PerlIO_flush(f);
1585 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1586 code = PerlIO_seek(PerlIONext(f),offset,whence);
1589 b->posn = PerlIO_tell(PerlIONext(f));
1596 PerlIOBuf_tell(PerlIO *f)
1598 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1599 Off_t posn = b->posn;
1601 posn += (b->ptr - b->buf);
1606 PerlIOBuf_close(PerlIO *f)
1608 IV code = PerlIOBase_close(f);
1609 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1610 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1615 b->ptr = b->end = b->buf;
1616 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1621 PerlIOBuf_setlinebuf(PerlIO *f)
1625 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1630 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1632 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1635 PerlIOBuf_alloc_buf(b);
1636 b->ptr = b->end - cnt;
1637 assert(b->ptr >= b->buf);
1641 PerlIOBuf_get_ptr(PerlIO *f)
1643 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1645 PerlIOBuf_alloc_buf(b);
1650 PerlIOBuf_get_cnt(PerlIO *f)
1652 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1654 PerlIOBuf_alloc_buf(b);
1655 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1656 return (b->end - b->ptr);
1661 PerlIOBuf_get_base(PerlIO *f)
1663 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1665 PerlIOBuf_alloc_buf(b);
1670 PerlIOBuf_bufsiz(PerlIO *f)
1672 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1674 PerlIOBuf_alloc_buf(b);
1675 return (b->end - b->buf);
1679 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1681 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1683 PerlIOBuf_alloc_buf(b);
1685 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1688 assert(PerlIO_get_cnt(f) == cnt);
1689 assert(b->ptr >= b->buf);
1691 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1694 PerlIO_funcs PerlIO_perlio = {
1711 PerlIOBase_clearerr,
1712 PerlIOBuf_setlinebuf,
1717 PerlIOBuf_set_ptrcnt,
1725 atexit(&PerlIO_cleanup);
1734 PerlIO_stdstreams();
1738 #undef PerlIO_stdout
1743 PerlIO_stdstreams();
1747 #undef PerlIO_stderr
1752 PerlIO_stdstreams();
1756 /*--------------------------------------------------------------------------------------*/
1758 #undef PerlIO_getname
1760 PerlIO_getname(PerlIO *f, char *buf)
1763 Perl_croak(aTHX_ "Don't know how to get file name");
1768 /*--------------------------------------------------------------------------------------*/
1769 /* Functions which can be called on any kind of PerlIO implemented
1775 PerlIO_getc(PerlIO *f)
1778 SSize_t count = PerlIO_read(f,buf,1);
1781 return (unsigned char) buf[0];
1786 #undef PerlIO_ungetc
1788 PerlIO_ungetc(PerlIO *f, int ch)
1793 if (PerlIO_unread(f,&buf,1) == 1)
1801 PerlIO_putc(PerlIO *f, int ch)
1804 return PerlIO_write(f,&buf,1);
1809 PerlIO_puts(PerlIO *f, const char *s)
1811 STRLEN len = strlen(s);
1812 return PerlIO_write(f,s,len);
1815 #undef PerlIO_rewind
1817 PerlIO_rewind(PerlIO *f)
1819 PerlIO_seek(f,(Off_t)0,SEEK_SET);
1823 #undef PerlIO_vprintf
1825 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1828 SV *sv = newSVpvn("",0);
1831 sv_vcatpvf(sv, fmt, &ap);
1833 return PerlIO_write(f,s,len);
1836 #undef PerlIO_printf
1838 PerlIO_printf(PerlIO *f,const char *fmt,...)
1843 result = PerlIO_vprintf(f,fmt,ap);
1848 #undef PerlIO_stdoutf
1850 PerlIO_stdoutf(const char *fmt,...)
1855 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1860 #undef PerlIO_tmpfile
1862 PerlIO_tmpfile(void)
1865 /* I have no idea how portable mkstemp() is ... */
1866 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1867 int fd = mkstemp(SvPVX(sv));
1871 f = PerlIO_fdopen(fd,"w+");
1874 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
1885 #endif /* USE_SFIO */
1886 #endif /* PERLIO_IS_STDIO */
1888 /*======================================================================================*/
1889 /* Now some functions in terms of above which may be needed even if
1890 we are not in true PerlIO mode
1894 #undef PerlIO_setpos
1896 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1898 return PerlIO_seek(f,*pos,0);
1901 #ifndef PERLIO_IS_STDIO
1902 #undef PerlIO_setpos
1904 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1906 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1907 return fsetpos64(f, pos);
1909 return fsetpos(f, pos);
1916 #undef PerlIO_getpos
1918 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1920 *pos = PerlIO_tell(f);
1924 #ifndef PERLIO_IS_STDIO
1925 #undef PerlIO_getpos
1927 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1929 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1930 return fgetpos64(f, pos);
1932 return fgetpos(f, pos);
1938 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1941 vprintf(char *pat, char *args)
1943 _doprnt(pat, args, stdout);
1944 return 0; /* wrong, but perl doesn't use the return value */
1948 vfprintf(FILE *fd, char *pat, char *args)
1950 _doprnt(pat, args, fd);
1951 return 0; /* wrong, but perl doesn't use the return value */
1956 #ifndef PerlIO_vsprintf
1958 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1960 int val = vsprintf(s, fmt, ap);
1963 if (strlen(s) >= (STRLEN)n)
1966 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1974 #ifndef PerlIO_sprintf
1976 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1981 result = PerlIO_vsprintf(s, n, fmt, ap);
1987 #endif /* !PERL_IMPLICIT_SYS */