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 */
102 void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
105 PerlIO_debug(char *fmt,...)
110 char *s = getenv("PERLIO_DEBUG");
112 dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
120 SV *sv = newSVpvn("",0);
124 s = CopFILE(PL_curcop);
127 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
128 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
137 /*--------------------------------------------------------------------------------------*/
139 typedef struct _PerlIO_funcs PerlIO_funcs;
145 IV (*Fileno)(PerlIO *f);
146 PerlIO * (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode);
147 PerlIO * (*Open)(PerlIO_funcs *tab, const char *path, const char *mode);
148 int (*Reopen)(const char *path, const char *mode, PerlIO *f);
149 IV (*Pushed)(PerlIO *f,const char *mode);
150 IV (*Popped)(PerlIO *f);
151 /* Unix-like functions - cf sfio line disciplines */
152 SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
153 SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
154 SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
155 IV (*Seek)(PerlIO *f, Off_t offset, int whence);
156 Off_t (*Tell)(PerlIO *f);
157 IV (*Close)(PerlIO *f);
158 /* Stdio-like buffered IO functions */
159 IV (*Flush)(PerlIO *f);
160 IV (*Fill)(PerlIO *f);
161 IV (*Eof)(PerlIO *f);
162 IV (*Error)(PerlIO *f);
163 void (*Clearerr)(PerlIO *f);
164 void (*Setlinebuf)(PerlIO *f);
165 /* Perl's snooping functions */
166 STDCHAR * (*Get_base)(PerlIO *f);
167 Size_t (*Get_bufsiz)(PerlIO *f);
168 STDCHAR * (*Get_ptr)(PerlIO *f);
169 SSize_t (*Get_cnt)(PerlIO *f);
170 void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
175 PerlIOl * next; /* Lower layer */
176 PerlIO_funcs * tab; /* Functions for this layer */
177 IV flags; /* Various flags for state */
180 /*--------------------------------------------------------------------------------------*/
183 #define PERLIO_F_EOF 0x00010000
184 #define PERLIO_F_CANWRITE 0x00020000
185 #define PERLIO_F_CANREAD 0x00040000
186 #define PERLIO_F_ERROR 0x00080000
187 #define PERLIO_F_TRUNCATE 0x00100000
188 #define PERLIO_F_APPEND 0x00200000
189 #define PERLIO_F_BINARY 0x00400000
190 #define PERLIO_F_UTF8 0x00800000
191 #define PERLIO_F_LINEBUF 0x01000000
192 #define PERLIO_F_WRBUF 0x02000000
193 #define PERLIO_F_RDBUF 0x04000000
194 #define PERLIO_F_TEMP 0x08000000
195 #define PERLIO_F_OPEN 0x10000000
197 #define PerlIOBase(f) (*(f))
198 #define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
199 #define PerlIONext(f) (&(PerlIOBase(f)->next))
201 /*--------------------------------------------------------------------------------------*/
202 /* Inner level routines */
204 /* Table of pointers to the PerlIO structs (malloc'ed) */
205 PerlIO *_perlio = NULL;
206 #define PERLIO_TABLE_SIZE 64
209 PerlIO_allocate(void)
211 /* Find a free slot in the table, allocating new table as necessary */
212 PerlIO **last = &_perlio;
217 last = (PerlIO **)(f);
218 for (i=1; i < PERLIO_TABLE_SIZE; i++)
226 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
234 PerlIO_cleantable(PerlIO **tablep)
236 PerlIO *table = *tablep;
240 PerlIO_cleantable((PerlIO **) &(table[0]));
241 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
258 PerlIO_cleantable(&_perlio);
262 PerlIO_pop(PerlIO *f)
267 (*l->tab->Popped)(f);
275 PerlIO_close(PerlIO *f)
277 int code = (*PerlIOBase(f)->tab->Close)(f);
286 /*--------------------------------------------------------------------------------------*/
287 /* Given the abstraction above the public API functions */
291 PerlIO_fileno(PerlIO *f)
293 return (*PerlIOBase(f)->tab->Fileno)(f);
297 extern PerlIO_funcs PerlIO_unix;
298 extern PerlIO_funcs PerlIO_perlio;
299 extern PerlIO_funcs PerlIO_stdio;
301 extern PerlIO_funcs PerlIO_mmap;
308 char *s = GvNAME(gv);
309 STRLEN l = GvNAMELEN(gv);
310 PerlIO_debug("%.*s\n",(int) l,s);
314 XS(XS_perlio_unimport)
318 char *s = GvNAME(gv);
319 STRLEN l = GvNAMELEN(gv);
320 PerlIO_debug("%.*s\n",(int) l,s);
325 PerlIO_find_layer(char *name, STRLEN len)
332 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
333 if (svp && (sv = *svp) && SvROK(sv))
339 PerlIO_define_layer(PerlIO_funcs *tab)
342 HV *stash = gv_stashpv("perlio::Layer", TRUE);
343 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
344 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
348 PerlIO_default_layer(I32 n)
353 PerlIO_funcs *tab = &PerlIO_stdio;
355 if (!PerlIO_layer_hv)
357 char *s = getenv("PERLIO");
358 newXS("perlio::import",XS_perlio_import,__FILE__);
359 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
360 PerlIO_layer_hv = get_hv("perlio::layers",GV_ADD|GV_ADDMULTI);
361 PerlIO_layer_av = get_av("perlio::layers",GV_ADD|GV_ADDMULTI);
362 PerlIO_define_layer(&PerlIO_unix);
363 PerlIO_define_layer(&PerlIO_perlio);
364 PerlIO_define_layer(&PerlIO_stdio);
366 PerlIO_define_layer(&PerlIO_mmap);
368 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
373 while (*s && isspace((unsigned char)*s))
379 while (*e && !isspace((unsigned char)*e))
381 layer = PerlIO_find_layer(s,e-s);
384 PerlIO_debug("Pushing %.*s\n",(e-s),s);
385 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
388 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
394 len = av_len(PerlIO_layer_av);
397 if (PerlIO_stdio.Set_ptrcnt)
399 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
403 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
405 len = av_len(PerlIO_layer_av);
409 svp = av_fetch(PerlIO_layer_av,n,0);
410 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
412 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
414 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
418 #define PerlIO_default_top() PerlIO_default_layer(-1)
419 #define PerlIO_default_btm() PerlIO_default_layer(0)
427 PerlIO_fdopen(0,"Ir");
428 PerlIO_fdopen(1,"Iw");
429 PerlIO_fdopen(2,"Iw");
435 PerlIO_fdopen(int fd, const char *mode)
437 PerlIO_funcs *tab = PerlIO_default_top();
440 return (*tab->Fdopen)(tab,fd,mode);
445 PerlIO_open(const char *path, const char *mode)
447 PerlIO_funcs *tab = PerlIO_default_top();
450 return (*tab->Open)(tab,path,mode);
454 PerlIOBase_pushed(PerlIO *f, const char *mode)
456 PerlIOl *l = PerlIOBase(f);
457 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
458 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
464 l->flags = PERLIO_F_CANREAD;
467 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
470 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
481 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
484 l->flags |= PERLIO_F_BINARY;
496 l->flags |= l->next->flags &
497 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
498 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
506 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
511 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
513 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
519 return PerlIO_open(path,mode);
524 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
526 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
531 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
533 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
538 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
540 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
545 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
547 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
552 PerlIO_tell(PerlIO *f)
554 return (*PerlIOBase(f)->tab->Tell)(f);
559 PerlIO_flush(PerlIO *f)
563 return (*PerlIOBase(f)->tab->Flush)(f);
567 PerlIO **table = &_perlio;
572 table = (PerlIO **)(f++);
573 for (i=1; i < PERLIO_TABLE_SIZE; i++)
575 if (*f && PerlIO_flush(f) != 0)
586 PerlIO_fill(PerlIO *f)
588 return (*PerlIOBase(f)->tab->Fill)(f);
593 PerlIO_isutf8(PerlIO *f)
595 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
600 PerlIO_eof(PerlIO *f)
602 return (*PerlIOBase(f)->tab->Eof)(f);
607 PerlIO_error(PerlIO *f)
609 return (*PerlIOBase(f)->tab->Error)(f);
612 #undef PerlIO_clearerr
614 PerlIO_clearerr(PerlIO *f)
616 (*PerlIOBase(f)->tab->Clearerr)(f);
619 #undef PerlIO_setlinebuf
621 PerlIO_setlinebuf(PerlIO *f)
623 (*PerlIOBase(f)->tab->Setlinebuf)(f);
626 #undef PerlIO_has_base
628 PerlIO_has_base(PerlIO *f)
632 return (PerlIOBase(f)->tab->Get_base != NULL);
637 #undef PerlIO_fast_gets
639 PerlIO_fast_gets(PerlIO *f)
643 PerlIOl *l = PerlIOBase(f);
644 return (l->tab->Set_ptrcnt != NULL);
649 #undef PerlIO_has_cntptr
651 PerlIO_has_cntptr(PerlIO *f)
655 PerlIO_funcs *tab = PerlIOBase(f)->tab;
656 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
661 #undef PerlIO_canset_cnt
663 PerlIO_canset_cnt(PerlIO *f)
667 PerlIOl *l = PerlIOBase(f);
668 return (l->tab->Set_ptrcnt != NULL);
673 #undef PerlIO_get_base
675 PerlIO_get_base(PerlIO *f)
677 return (*PerlIOBase(f)->tab->Get_base)(f);
680 #undef PerlIO_get_bufsiz
682 PerlIO_get_bufsiz(PerlIO *f)
684 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
687 #undef PerlIO_get_ptr
689 PerlIO_get_ptr(PerlIO *f)
691 return (*PerlIOBase(f)->tab->Get_ptr)(f);
694 #undef PerlIO_get_cnt
696 PerlIO_get_cnt(PerlIO *f)
698 return (*PerlIOBase(f)->tab->Get_cnt)(f);
701 #undef PerlIO_set_cnt
703 PerlIO_set_cnt(PerlIO *f,int cnt)
705 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
708 #undef PerlIO_set_ptrcnt
710 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
712 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
715 /*--------------------------------------------------------------------------------------*/
716 /* "Methods" of the "base class" */
719 PerlIOBase_fileno(PerlIO *f)
721 return PerlIO_fileno(PerlIONext(f));
725 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
728 Newc('L',l,tab->size,char,PerlIOl);
731 Zero(l,tab->size,char);
735 if ((*l->tab->Pushed)(f,mode) != 0)
745 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
747 Off_t old = PerlIO_tell(f);
748 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
750 Off_t new = PerlIO_tell(f);
757 PerlIOBase_noop_ok(PerlIO *f)
763 PerlIOBase_noop_fail(PerlIO *f)
769 PerlIOBase_close(PerlIO *f)
772 if (PerlIO_flush(f) != 0)
774 if (PerlIO_close(PerlIONext(f)) != 0)
776 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
781 PerlIOBase_eof(PerlIO *f)
785 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
791 PerlIOBase_error(PerlIO *f)
795 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
801 PerlIOBase_clearerr(PerlIO *f)
805 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
810 PerlIOBase_setlinebuf(PerlIO *f)
817 /*--------------------------------------------------------------------------------------*/
818 /* Bottom-most level for UNIX-like case */
822 struct _PerlIO base; /* The generic part */
823 int fd; /* UNIX like file descriptor */
824 int oflags; /* open/fcntl flags */
828 PerlIOUnix_oflags(const char *mode)
843 oflags = O_CREAT|O_TRUNC;
854 oflags = O_CREAT|O_APPEND;
864 if (*mode || oflags == -1)
873 PerlIOUnix_fileno(PerlIO *f)
875 return PerlIOSelf(f,PerlIOUnix)->fd;
879 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
886 int oflags = PerlIOUnix_oflags(mode);
889 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
892 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
899 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
902 int oflags = PerlIOUnix_oflags(mode);
905 int fd = open(path,oflags,0666);
908 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
911 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
918 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
920 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
921 int oflags = PerlIOUnix_oflags(mode);
922 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
923 (*PerlIOBase(f)->tab->Close)(f);
926 int fd = open(path,oflags,0666);
931 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
939 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
941 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
942 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
946 SSize_t len = read(fd,vbuf,count);
947 if (len >= 0 || errno != EINTR)
950 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
951 else if (len == 0 && count != 0)
952 PerlIOBase(f)->flags |= PERLIO_F_EOF;
959 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
961 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
964 SSize_t len = write(fd,vbuf,count);
965 if (len >= 0 || errno != EINTR)
968 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
975 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
977 Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
978 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
979 return (new == (Off_t) -1) ? -1 : 0;
983 PerlIOUnix_tell(PerlIO *f)
985 return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
989 PerlIOUnix_close(PerlIO *f)
991 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
993 while (close(fd) != 0)
1003 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1008 PerlIO_funcs PerlIO_unix = {
1025 PerlIOBase_noop_fail,
1028 PerlIOBase_clearerr,
1029 PerlIOBase_setlinebuf,
1030 NULL, /* get_base */
1031 NULL, /* get_bufsiz */
1034 NULL, /* set_ptrcnt */
1037 /*--------------------------------------------------------------------------------------*/
1038 /* stdio as a layer */
1040 #if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
1041 #define fseek fseeko
1044 #if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
1045 #define ftell ftello
1051 struct _PerlIO base;
1052 FILE * stdio; /* The stream */
1056 PerlIOStdio_fileno(PerlIO *f)
1058 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1063 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1091 stdio = fdopen(fd,mode);
1094 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1101 #undef PerlIO_importFILE
1103 PerlIO_importFILE(FILE *stdio, int fl)
1108 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1115 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1118 FILE *stdio = fopen(path,mode);
1121 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1128 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1130 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1131 FILE *stdio = freopen(path,mode,s->stdio);
1139 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1141 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1145 STDCHAR *buf = (STDCHAR *) vbuf;
1146 /* Perl is expecting PerlIO_getc() to fill the buffer
1147 * Linux's stdio does not do that for fread()
1157 got = fread(vbuf,1,count,s);
1162 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1164 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1165 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1169 int ch = *buf-- & 0xff;
1170 if (ungetc(ch,s) != ch)
1179 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1181 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1185 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1187 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1188 return fseek(stdio,offset,whence);
1192 PerlIOStdio_tell(PerlIO *f)
1194 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1195 return ftell(stdio);
1199 PerlIOStdio_close(PerlIO *f)
1201 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1205 PerlIOStdio_flush(PerlIO *f)
1207 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1208 return fflush(stdio);
1212 PerlIOStdio_fill(PerlIO *f)
1214 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1216 if (fflush(stdio) != 0)
1219 if (c == EOF || ungetc(c,stdio) != c)
1225 PerlIOStdio_eof(PerlIO *f)
1227 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1231 PerlIOStdio_error(PerlIO *f)
1233 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1237 PerlIOStdio_clearerr(PerlIO *f)
1239 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1243 PerlIOStdio_setlinebuf(PerlIO *f)
1245 #ifdef HAS_SETLINEBUF
1246 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1248 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1254 PerlIOStdio_get_base(PerlIO *f)
1256 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1257 return FILE_base(stdio);
1261 PerlIOStdio_get_bufsiz(PerlIO *f)
1263 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1264 return FILE_bufsiz(stdio);
1268 #ifdef USE_STDIO_PTR
1270 PerlIOStdio_get_ptr(PerlIO *f)
1272 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1273 return FILE_ptr(stdio);
1277 PerlIOStdio_get_cnt(PerlIO *f)
1279 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1280 return FILE_cnt(stdio);
1284 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1286 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1289 #ifdef STDIO_PTR_LVALUE
1290 FILE_ptr(stdio) = ptr;
1291 #ifdef STDIO_PTR_LVAL_SETS_CNT
1292 if (FILE_cnt(stdio) != (cnt))
1295 assert(FILE_cnt(stdio) == (cnt));
1298 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1299 /* Setting ptr _does_ change cnt - we are done */
1302 #else /* STDIO_PTR_LVALUE */
1304 #endif /* STDIO_PTR_LVALUE */
1306 /* Now (or only) set cnt */
1307 #ifdef STDIO_CNT_LVALUE
1308 FILE_cnt(stdio) = cnt;
1309 #else /* STDIO_CNT_LVALUE */
1310 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1311 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1312 #else /* STDIO_PTR_LVAL_SETS_CNT */
1314 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1315 #endif /* STDIO_CNT_LVALUE */
1320 PerlIO_funcs PerlIO_stdio = {
1322 sizeof(PerlIOStdio),
1340 PerlIOStdio_clearerr,
1341 PerlIOStdio_setlinebuf,
1343 PerlIOStdio_get_base,
1344 PerlIOStdio_get_bufsiz,
1349 #ifdef USE_STDIO_PTR
1350 PerlIOStdio_get_ptr,
1351 PerlIOStdio_get_cnt,
1352 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1353 PerlIOStdio_set_ptrcnt
1354 #else /* STDIO_PTR_LVALUE */
1356 #endif /* STDIO_PTR_LVALUE */
1357 #else /* USE_STDIO_PTR */
1361 #endif /* USE_STDIO_PTR */
1364 #undef PerlIO_exportFILE
1366 PerlIO_exportFILE(PerlIO *f, int fl)
1369 /* Should really push stdio discipline when we have them */
1370 return fdopen(PerlIO_fileno(f),"r+");
1373 #undef PerlIO_findFILE
1375 PerlIO_findFILE(PerlIO *f)
1377 return PerlIO_exportFILE(f,0);
1380 #undef PerlIO_releaseFILE
1382 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1386 /*--------------------------------------------------------------------------------------*/
1387 /* perlio buffer layer */
1391 struct _PerlIO base;
1392 Off_t posn; /* Offset of buf into the file */
1393 STDCHAR * buf; /* Start of buffer */
1394 STDCHAR * end; /* End of valid part of buffer */
1395 STDCHAR * ptr; /* Current position in buffer */
1396 Size_t bufsiz; /* Size of buffer */
1397 IV oneword; /* Emergency buffer */
1402 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1404 PerlIO_funcs *tab = PerlIO_default_btm();
1412 f = (*tab->Fdopen)(tab,fd,mode);
1415 /* Initial stderr is unbuffered */
1416 if (!init || fd != 2)
1418 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1419 b->posn = PerlIO_tell(PerlIONext(f));
1427 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1429 PerlIO_funcs *tab = PerlIO_default_btm();
1430 PerlIO *f = (*tab->Open)(tab,path,mode);
1433 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1434 b->posn = PerlIO_tell(PerlIONext(f));
1440 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1442 PerlIO *next = PerlIONext(f);
1443 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1445 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1448 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1449 b->posn = PerlIO_tell(PerlIONext(f));
1454 /* This "flush" is akin to sfio's sync in that it handles files in either
1458 PerlIOBuf_flush(PerlIO *f)
1460 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1462 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1464 /* write() the buffer */
1465 STDCHAR *p = b->buf;
1469 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1476 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1481 b->posn += (p - b->buf);
1483 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1485 /* Note position change */
1486 b->posn += (b->ptr - b->buf);
1487 if (b->ptr < b->end)
1489 /* We did not consume all of it */
1490 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1492 b->posn = PerlIO_tell(PerlIONext(f));
1496 b->ptr = b->end = b->buf;
1497 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1498 if (PerlIO_flush(PerlIONext(f)) != 0)
1504 PerlIOBuf_fill(PerlIO *f)
1506 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1508 if (PerlIO_flush(f) != 0)
1510 b->ptr = b->end = b->buf;
1511 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1515 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1517 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1520 b->end = b->buf+avail;
1521 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1526 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1528 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1529 STDCHAR *buf = (STDCHAR *) vbuf;
1535 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1539 SSize_t avail = (b->end - b->ptr);
1540 if ((SSize_t) count < avail)
1544 Copy(b->ptr,buf,avail,char);
1550 if (count && (b->ptr >= b->end))
1552 if (PerlIO_fill(f) != 0)
1562 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1564 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1565 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1568 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1574 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1576 avail = (b->ptr - b->buf);
1577 if (avail > (SSize_t) count)
1584 if (avail > (SSize_t) count)
1586 b->end = b->ptr + avail;
1593 Copy(buf,b->ptr,avail,char);
1597 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1604 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1606 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1607 const STDCHAR *buf = (const STDCHAR *) vbuf;
1611 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1615 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1616 if ((SSize_t) count < avail)
1618 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1619 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1639 Copy(buf,b->ptr,avail,char);
1646 if (b->ptr >= (b->buf + b->bufsiz))
1653 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1655 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1656 int code = PerlIO_flush(f);
1659 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1660 code = PerlIO_seek(PerlIONext(f),offset,whence);
1663 b->posn = PerlIO_tell(PerlIONext(f));
1670 PerlIOBuf_tell(PerlIO *f)
1672 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1673 Off_t posn = b->posn;
1675 posn += (b->ptr - b->buf);
1680 PerlIOBuf_close(PerlIO *f)
1682 IV code = PerlIOBase_close(f);
1683 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1684 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1689 b->ptr = b->end = b->buf;
1690 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1695 PerlIOBuf_setlinebuf(PerlIO *f)
1699 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1704 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1706 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1710 b->ptr = b->end - cnt;
1711 assert(b->ptr >= b->buf);
1715 PerlIOBuf_get_ptr(PerlIO *f)
1717 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1724 PerlIOBuf_get_cnt(PerlIO *f)
1726 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1729 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1730 return (b->end - b->ptr);
1735 PerlIOBuf_get_base(PerlIO *f)
1737 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1742 New('B',b->buf,b->bufsiz,STDCHAR);
1745 b->buf = (STDCHAR *)&b->oneword;
1746 b->bufsiz = sizeof(b->oneword);
1755 PerlIOBuf_bufsiz(PerlIO *f)
1757 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1760 return (b->end - b->buf);
1764 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1766 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1770 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1773 assert(PerlIO_get_cnt(f) == cnt);
1774 assert(b->ptr >= b->buf);
1776 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1779 PerlIO_funcs PerlIO_perlio = {
1799 PerlIOBase_clearerr,
1800 PerlIOBuf_setlinebuf,
1805 PerlIOBuf_set_ptrcnt,
1809 /*--------------------------------------------------------------------------------------*/
1810 /* mmap as "buffer" layer */
1814 PerlIOBuf base; /* PerlIOBuf stuff */
1815 Mmap_t mptr; /* Mapped address */
1816 Size_t len; /* mapped length */
1817 STDCHAR *bbuf; /* malloced buffer if map fails */
1821 static size_t page_size = 0;
1824 PerlIOMmap_map(PerlIO *f)
1827 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1828 PerlIOBuf *b = &m->base;
1829 IV flags = PerlIOBase(f)->flags;
1833 if (flags & PERLIO_F_CANREAD)
1835 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1836 int fd = PerlIO_fileno(f);
1838 code = fstat(fd,&st);
1839 if (code == 0 && S_ISREG(st.st_mode))
1841 SSize_t len = st.st_size - b->posn;
1846 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1848 SETERRNO(0,SS$_NORMAL);
1849 # ifdef _SC_PAGESIZE
1850 page_size = sysconf(_SC_PAGESIZE);
1852 page_size = sysconf(_SC_PAGE_SIZE);
1854 if ((long)page_size < 0) {
1859 (void)SvUPGRADE(error, SVt_PV);
1860 msg = SvPVx(error, n_a);
1861 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1864 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1868 # ifdef HAS_GETPAGESIZE
1869 page_size = getpagesize();
1871 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
1872 page_size = PAGESIZE; /* compiletime, bad */
1876 if ((IV)page_size <= 0)
1877 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1881 /* This is a hack - should never happen - open should have set it ! */
1882 b->posn = PerlIO_tell(PerlIONext(f));
1884 posn = (b->posn / page_size) * page_size;
1885 len = st.st_size - posn;
1886 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1887 if (m->mptr && m->mptr != (Mmap_t) -1)
1889 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1890 madvise(m->mptr, len, MADV_SEQUENTIAL);
1892 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1893 b->end = ((STDCHAR *)m->mptr) + len;
1894 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
1905 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1907 b->ptr = b->end = b->ptr;
1916 PerlIOMmap_unmap(PerlIO *f)
1918 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1919 PerlIOBuf *b = &m->base;
1925 code = munmap(m->mptr, m->len);
1929 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1932 b->ptr = b->end = b->buf;
1933 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1939 PerlIOMmap_get_base(PerlIO *f)
1941 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1942 PerlIOBuf *b = &m->base;
1943 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1945 /* Already have a readbuffer in progress */
1950 /* We have a write buffer or flushed PerlIOBuf read buffer */
1951 m->bbuf = b->buf; /* save it in case we need it again */
1952 b->buf = NULL; /* Clear to trigger below */
1956 PerlIOMmap_map(f); /* Try and map it */
1959 /* Map did not work - recover PerlIOBuf buffer if we have one */
1963 b->ptr = b->end = b->buf;
1966 return PerlIOBuf_get_base(f);
1970 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
1972 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1973 PerlIOBuf *b = &m->base;
1974 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1976 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
1979 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1984 /* Loose the unwritable mapped buffer */
1986 /* If flush took the "buffer" see if we have one from before */
1987 if (!b->buf && m->bbuf)
1991 PerlIOBuf_get_base(f);
1995 return PerlIOBuf_unread(f,vbuf,count);
1999 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2001 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2002 PerlIOBuf *b = &m->base;
2003 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2005 /* No, or wrong sort of, buffer */
2008 if (PerlIOMmap_unmap(f) != 0)
2011 /* If unmap took the "buffer" see if we have one from before */
2012 if (!b->buf && m->bbuf)
2016 PerlIOBuf_get_base(f);
2020 return PerlIOBuf_write(f,vbuf,count);
2024 PerlIOMmap_flush(PerlIO *f)
2026 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2027 PerlIOBuf *b = &m->base;
2028 IV code = PerlIOBuf_flush(f);
2029 /* Now we are "synced" at PerlIOBuf level */
2034 /* Unmap the buffer */
2035 if (PerlIOMmap_unmap(f) != 0)
2040 /* We seem to have a PerlIOBuf buffer which was not mapped
2041 * remember it in case we need one later
2050 PerlIOMmap_fill(PerlIO *f)
2052 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2053 IV code = PerlIO_flush(f);
2054 if (code == 0 && !b->buf)
2056 code = PerlIOMmap_map(f);
2058 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2060 code = PerlIOBuf_fill(f);
2066 PerlIOMmap_close(PerlIO *f)
2068 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2069 PerlIOBuf *b = &m->base;
2070 IV code = PerlIO_flush(f);
2075 b->ptr = b->end = b->buf;
2077 if (PerlIOBuf_close(f) != 0)
2083 PerlIO_funcs PerlIO_mmap = {
2103 PerlIOBase_clearerr,
2104 PerlIOBuf_setlinebuf,
2105 PerlIOMmap_get_base,
2109 PerlIOBuf_set_ptrcnt,
2112 #endif /* HAS_MMAP */
2121 atexit(&PerlIO_cleanup);
2130 PerlIO_stdstreams();
2134 #undef PerlIO_stdout
2139 PerlIO_stdstreams();
2143 #undef PerlIO_stderr
2148 PerlIO_stdstreams();
2152 /*--------------------------------------------------------------------------------------*/
2154 #undef PerlIO_getname
2156 PerlIO_getname(PerlIO *f, char *buf)
2159 Perl_croak(aTHX_ "Don't know how to get file name");
2164 /*--------------------------------------------------------------------------------------*/
2165 /* Functions which can be called on any kind of PerlIO implemented
2171 PerlIO_getc(PerlIO *f)
2174 SSize_t count = PerlIO_read(f,buf,1);
2177 return (unsigned char) buf[0];
2182 #undef PerlIO_ungetc
2184 PerlIO_ungetc(PerlIO *f, int ch)
2189 if (PerlIO_unread(f,&buf,1) == 1)
2197 PerlIO_putc(PerlIO *f, int ch)
2200 return PerlIO_write(f,&buf,1);
2205 PerlIO_puts(PerlIO *f, const char *s)
2207 STRLEN len = strlen(s);
2208 return PerlIO_write(f,s,len);
2211 #undef PerlIO_rewind
2213 PerlIO_rewind(PerlIO *f)
2215 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2219 #undef PerlIO_vprintf
2221 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2224 SV *sv = newSVpvn("",0);
2227 sv_vcatpvf(sv, fmt, &ap);
2229 return PerlIO_write(f,s,len);
2232 #undef PerlIO_printf
2234 PerlIO_printf(PerlIO *f,const char *fmt,...)
2239 result = PerlIO_vprintf(f,fmt,ap);
2244 #undef PerlIO_stdoutf
2246 PerlIO_stdoutf(const char *fmt,...)
2251 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2256 #undef PerlIO_tmpfile
2258 PerlIO_tmpfile(void)
2261 /* I have no idea how portable mkstemp() is ... */
2262 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2263 int fd = mkstemp(SvPVX(sv));
2267 f = PerlIO_fdopen(fd,"w+");
2270 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2281 #endif /* USE_SFIO */
2282 #endif /* PERLIO_IS_STDIO */
2284 /*======================================================================================*/
2285 /* Now some functions in terms of above which may be needed even if
2286 we are not in true PerlIO mode
2290 #undef PerlIO_setpos
2292 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2294 return PerlIO_seek(f,*pos,0);
2297 #ifndef PERLIO_IS_STDIO
2298 #undef PerlIO_setpos
2300 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2302 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2303 return fsetpos64(f, pos);
2305 return fsetpos(f, pos);
2312 #undef PerlIO_getpos
2314 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2316 *pos = PerlIO_tell(f);
2320 #ifndef PERLIO_IS_STDIO
2321 #undef PerlIO_getpos
2323 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2325 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2326 return fgetpos64(f, pos);
2328 return fgetpos(f, pos);
2334 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2337 vprintf(char *pat, char *args)
2339 _doprnt(pat, args, stdout);
2340 return 0; /* wrong, but perl doesn't use the return value */
2344 vfprintf(FILE *fd, char *pat, char *args)
2346 _doprnt(pat, args, fd);
2347 return 0; /* wrong, but perl doesn't use the return value */
2352 #ifndef PerlIO_vsprintf
2354 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2356 int val = vsprintf(s, fmt, ap);
2359 if (strlen(s) >= (STRLEN)n)
2362 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
2370 #ifndef PerlIO_sprintf
2372 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2377 result = PerlIO_vsprintf(s, n, fmt, ap);
2383 #endif /* !PERL_IMPLICIT_SYS */