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.
93 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
103 void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2)));
106 PerlIO_debug(char *fmt,...)
111 char *s = PerlEnv_getenv("PERLIO_DEBUG");
113 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
121 SV *sv = newSVpvn("",0);
125 s = CopFILE(PL_curcop);
128 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
129 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
132 PerlLIO_write(dbg,s,len);
138 /*--------------------------------------------------------------------------------------*/
140 /* Inner level routines */
142 /* Table of pointers to the PerlIO structs (malloc'ed) */
143 PerlIO *_perlio = NULL;
144 #define PERLIO_TABLE_SIZE 64
147 PerlIO_allocate(void)
149 /* Find a free slot in the table, allocating new table as necessary */
150 PerlIO **last = &_perlio;
155 last = (PerlIO **)(f);
156 for (i=1; i < PERLIO_TABLE_SIZE; i++)
164 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
172 PerlIO_cleantable(PerlIO **tablep)
174 PerlIO *table = *tablep;
178 PerlIO_cleantable((PerlIO **) &(table[0]));
179 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
196 PerlIO_cleantable(&_perlio);
200 PerlIO_pop(PerlIO *f)
205 (*l->tab->Popped)(f);
213 PerlIO_close(PerlIO *f)
215 int code = (*PerlIOBase(f)->tab->Close)(f);
224 /*--------------------------------------------------------------------------------------*/
225 /* Given the abstraction above the public API functions */
229 PerlIO_fileno(PerlIO *f)
231 return (*PerlIOBase(f)->tab->Fileno)(f);
238 char *s = GvNAME(gv);
239 STRLEN l = GvNAMELEN(gv);
240 PerlIO_debug("%.*s\n",(int) l,s);
244 XS(XS_perlio_unimport)
248 char *s = GvNAME(gv);
249 STRLEN l = GvNAMELEN(gv);
250 PerlIO_debug("%.*s\n",(int) l,s);
255 PerlIO_find_layer(char *name, STRLEN len)
262 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
263 if (svp && (sv = *svp) && SvROK(sv))
269 PerlIO_define_layer(PerlIO_funcs *tab)
272 HV *stash = gv_stashpv("perlio::Layer", TRUE);
273 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
274 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
278 PerlIO_default_layer(I32 n)
283 PerlIO_funcs *tab = &PerlIO_stdio;
285 if (!PerlIO_layer_hv)
287 char *s = PerlEnv_getenv("PERLIO");
288 newXS("perlio::import",XS_perlio_import,__FILE__);
289 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
290 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
291 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
292 PerlIO_define_layer(&PerlIO_unix);
293 PerlIO_define_layer(&PerlIO_perlio);
294 PerlIO_define_layer(&PerlIO_stdio);
296 PerlIO_define_layer(&PerlIO_mmap);
298 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
303 while (*s && isSPACE((unsigned char)*s))
309 while (*e && !isSPACE((unsigned char)*e))
311 layer = PerlIO_find_layer(s,e-s);
314 PerlIO_debug("Pushing %.*s\n",(e-s),s);
315 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
318 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
324 len = av_len(PerlIO_layer_av);
327 if (PerlIO_stdio.Set_ptrcnt)
329 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
333 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
335 len = av_len(PerlIO_layer_av);
339 svp = av_fetch(PerlIO_layer_av,n,0);
340 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
342 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
344 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
348 #define PerlIO_default_top() PerlIO_default_layer(-1)
349 #define PerlIO_default_btm() PerlIO_default_layer(0)
357 PerlIO_fdopen(0,"Ir");
358 PerlIO_fdopen(1,"Iw");
359 PerlIO_fdopen(2,"Iw");
364 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
367 Newc('L',l,tab->size,char,PerlIOl);
370 Zero(l,tab->size,char);
374 if ((*l->tab->Pushed)(f,mode) != 0)
385 PerlIO_fdopen(int fd, const char *mode)
387 PerlIO_funcs *tab = PerlIO_default_top();
390 return (*tab->Fdopen)(tab,fd,mode);
395 PerlIO_open(const char *path, const char *mode)
397 PerlIO_funcs *tab = PerlIO_default_top();
400 return (*tab->Open)(tab,path,mode);
405 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
410 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
412 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
418 return PerlIO_open(path,mode);
423 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
425 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
430 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
432 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
437 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
439 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
444 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
446 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
451 PerlIO_tell(PerlIO *f)
453 return (*PerlIOBase(f)->tab->Tell)(f);
458 PerlIO_flush(PerlIO *f)
462 return (*PerlIOBase(f)->tab->Flush)(f);
466 PerlIO **table = &_perlio;
471 table = (PerlIO **)(f++);
472 for (i=1; i < PERLIO_TABLE_SIZE; i++)
474 if (*f && PerlIO_flush(f) != 0)
485 PerlIO_fill(PerlIO *f)
487 return (*PerlIOBase(f)->tab->Fill)(f);
492 PerlIO_isutf8(PerlIO *f)
494 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
499 PerlIO_eof(PerlIO *f)
501 return (*PerlIOBase(f)->tab->Eof)(f);
506 PerlIO_error(PerlIO *f)
508 return (*PerlIOBase(f)->tab->Error)(f);
511 #undef PerlIO_clearerr
513 PerlIO_clearerr(PerlIO *f)
515 (*PerlIOBase(f)->tab->Clearerr)(f);
518 #undef PerlIO_setlinebuf
520 PerlIO_setlinebuf(PerlIO *f)
522 (*PerlIOBase(f)->tab->Setlinebuf)(f);
525 #undef PerlIO_has_base
527 PerlIO_has_base(PerlIO *f)
531 return (PerlIOBase(f)->tab->Get_base != NULL);
536 #undef PerlIO_fast_gets
538 PerlIO_fast_gets(PerlIO *f)
542 PerlIOl *l = PerlIOBase(f);
543 return (l->tab->Set_ptrcnt != NULL);
548 #undef PerlIO_has_cntptr
550 PerlIO_has_cntptr(PerlIO *f)
554 PerlIO_funcs *tab = PerlIOBase(f)->tab;
555 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
560 #undef PerlIO_canset_cnt
562 PerlIO_canset_cnt(PerlIO *f)
566 PerlIOl *l = PerlIOBase(f);
567 return (l->tab->Set_ptrcnt != NULL);
572 #undef PerlIO_get_base
574 PerlIO_get_base(PerlIO *f)
576 return (*PerlIOBase(f)->tab->Get_base)(f);
579 #undef PerlIO_get_bufsiz
581 PerlIO_get_bufsiz(PerlIO *f)
583 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
586 #undef PerlIO_get_ptr
588 PerlIO_get_ptr(PerlIO *f)
590 return (*PerlIOBase(f)->tab->Get_ptr)(f);
593 #undef PerlIO_get_cnt
595 PerlIO_get_cnt(PerlIO *f)
597 return (*PerlIOBase(f)->tab->Get_cnt)(f);
600 #undef PerlIO_set_cnt
602 PerlIO_set_cnt(PerlIO *f,int cnt)
604 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
607 #undef PerlIO_set_ptrcnt
609 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
611 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
614 /*--------------------------------------------------------------------------------------*/
615 /* "Methods" of the "base class" */
618 PerlIOBase_fileno(PerlIO *f)
620 return PerlIO_fileno(PerlIONext(f));
624 PerlIOBase_pushed(PerlIO *f, const char *mode)
626 PerlIOl *l = PerlIOBase(f);
627 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
628 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
634 l->flags = PERLIO_F_CANREAD;
637 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
640 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
651 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
654 l->flags |= PERLIO_F_BINARY;
666 l->flags |= l->next->flags &
667 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
668 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
675 PerlIOBase_popped(PerlIO *f)
681 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
683 Off_t old = PerlIO_tell(f);
684 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
686 Off_t new = PerlIO_tell(f);
693 PerlIOBase_noop_ok(PerlIO *f)
699 PerlIOBase_noop_fail(PerlIO *f)
705 PerlIOBase_close(PerlIO *f)
708 if (PerlIO_flush(f) != 0)
710 if (PerlIO_close(PerlIONext(f)) != 0)
712 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
717 PerlIOBase_eof(PerlIO *f)
721 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
727 PerlIOBase_error(PerlIO *f)
731 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
737 PerlIOBase_clearerr(PerlIO *f)
741 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
746 PerlIOBase_setlinebuf(PerlIO *f)
751 /*--------------------------------------------------------------------------------------*/
752 /* Bottom-most level for UNIX-like case */
756 struct _PerlIO base; /* The generic part */
757 int fd; /* UNIX like file descriptor */
758 int oflags; /* open/fcntl flags */
762 PerlIOUnix_oflags(const char *mode)
777 oflags = O_CREAT|O_TRUNC;
788 oflags = O_CREAT|O_APPEND;
798 if (*mode || oflags == -1)
807 PerlIOUnix_fileno(PerlIO *f)
809 return PerlIOSelf(f,PerlIOUnix)->fd;
813 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
820 int oflags = PerlIOUnix_oflags(mode);
823 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
826 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
833 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
836 int oflags = PerlIOUnix_oflags(mode);
839 int fd = PerlLIO_open3(path,oflags,0666);
842 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
845 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
852 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
854 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
855 int oflags = PerlIOUnix_oflags(mode);
856 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
857 (*PerlIOBase(f)->tab->Close)(f);
860 int fd = PerlLIO_open3(path,oflags,0666);
865 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
873 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
875 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
876 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
880 SSize_t len = PerlLIO_read(fd,vbuf,count);
881 if (len >= 0 || errno != EINTR)
884 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
885 else if (len == 0 && count != 0)
886 PerlIOBase(f)->flags |= PERLIO_F_EOF;
893 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
895 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
898 SSize_t len = PerlLIO_write(fd,vbuf,count);
899 if (len >= 0 || errno != EINTR)
902 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
909 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
911 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
912 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
913 return (new == (Off_t) -1) ? -1 : 0;
917 PerlIOUnix_tell(PerlIO *f)
919 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
923 PerlIOUnix_close(PerlIO *f)
925 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
927 while (PerlLIO_close(fd) != 0)
937 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
942 PerlIO_funcs PerlIO_unix = {
958 PerlIOBase_noop_ok, /* flush */
959 PerlIOBase_noop_fail, /* fill */
963 PerlIOBase_setlinebuf,
965 NULL, /* get_bufsiz */
968 NULL, /* set_ptrcnt */
971 /*--------------------------------------------------------------------------------------*/
972 /* stdio as a layer */
977 FILE * stdio; /* The stream */
981 PerlIOStdio_fileno(PerlIO *f)
983 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
988 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1016 stdio = fdopen(fd,mode);
1019 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1026 #undef PerlIO_importFILE
1028 PerlIO_importFILE(FILE *stdio, int fl)
1033 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1040 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1043 FILE *stdio = fopen(path,mode);
1046 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1053 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1055 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1056 FILE *stdio = freopen(path,mode,s->stdio);
1064 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1066 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1070 STDCHAR *buf = (STDCHAR *) vbuf;
1071 /* Perl is expecting PerlIO_getc() to fill the buffer
1072 * Linux's stdio does not do that for fread()
1082 got = fread(vbuf,1,count,s);
1087 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1089 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1090 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1094 int ch = *buf-- & 0xff;
1095 if (ungetc(ch,s) != ch)
1104 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1106 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1110 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1112 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1113 return fseek(stdio,offset,whence);
1117 PerlIOStdio_tell(PerlIO *f)
1119 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1120 return ftell(stdio);
1124 PerlIOStdio_close(PerlIO *f)
1126 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1130 PerlIOStdio_flush(PerlIO *f)
1132 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1133 return fflush(stdio);
1137 PerlIOStdio_fill(PerlIO *f)
1139 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1141 if (fflush(stdio) != 0)
1144 if (c == EOF || ungetc(c,stdio) != c)
1150 PerlIOStdio_eof(PerlIO *f)
1152 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1156 PerlIOStdio_error(PerlIO *f)
1158 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1162 PerlIOStdio_clearerr(PerlIO *f)
1164 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1168 PerlIOStdio_setlinebuf(PerlIO *f)
1170 #ifdef HAS_SETLINEBUF
1171 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1173 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1179 PerlIOStdio_get_base(PerlIO *f)
1181 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1182 return FILE_base(stdio);
1186 PerlIOStdio_get_bufsiz(PerlIO *f)
1188 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1189 return FILE_bufsiz(stdio);
1193 #ifdef USE_STDIO_PTR
1195 PerlIOStdio_get_ptr(PerlIO *f)
1197 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1198 return FILE_ptr(stdio);
1202 PerlIOStdio_get_cnt(PerlIO *f)
1204 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1205 return FILE_cnt(stdio);
1209 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1211 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1214 #ifdef STDIO_PTR_LVALUE
1215 FILE_ptr(stdio) = ptr;
1216 #ifdef STDIO_PTR_LVAL_SETS_CNT
1217 if (FILE_cnt(stdio) != (cnt))
1220 assert(FILE_cnt(stdio) == (cnt));
1223 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1224 /* Setting ptr _does_ change cnt - we are done */
1227 #else /* STDIO_PTR_LVALUE */
1229 #endif /* STDIO_PTR_LVALUE */
1231 /* Now (or only) set cnt */
1232 #ifdef STDIO_CNT_LVALUE
1233 FILE_cnt(stdio) = cnt;
1234 #else /* STDIO_CNT_LVALUE */
1235 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1236 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1237 #else /* STDIO_PTR_LVAL_SETS_CNT */
1239 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1240 #endif /* STDIO_CNT_LVALUE */
1245 PerlIO_funcs PerlIO_stdio = {
1247 sizeof(PerlIOStdio),
1265 PerlIOStdio_clearerr,
1266 PerlIOStdio_setlinebuf,
1268 PerlIOStdio_get_base,
1269 PerlIOStdio_get_bufsiz,
1274 #ifdef USE_STDIO_PTR
1275 PerlIOStdio_get_ptr,
1276 PerlIOStdio_get_cnt,
1277 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1278 PerlIOStdio_set_ptrcnt
1279 #else /* STDIO_PTR_LVALUE */
1281 #endif /* STDIO_PTR_LVALUE */
1282 #else /* USE_STDIO_PTR */
1286 #endif /* USE_STDIO_PTR */
1289 #undef PerlIO_exportFILE
1291 PerlIO_exportFILE(PerlIO *f, int fl)
1294 /* Should really push stdio discipline when we have them */
1295 return fdopen(PerlIO_fileno(f),"r+");
1298 #undef PerlIO_findFILE
1300 PerlIO_findFILE(PerlIO *f)
1302 return PerlIO_exportFILE(f,0);
1305 #undef PerlIO_releaseFILE
1307 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1311 /*--------------------------------------------------------------------------------------*/
1312 /* perlio buffer layer */
1315 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1317 PerlIO_funcs *tab = PerlIO_default_btm();
1325 f = (*tab->Fdopen)(tab,fd,mode);
1328 /* Initial stderr is unbuffered */
1329 if (!init || fd != 2)
1331 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1332 b->posn = PerlIO_tell(PerlIONext(f));
1339 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1341 PerlIO_funcs *tab = PerlIO_default_btm();
1342 PerlIO *f = (*tab->Open)(tab,path,mode);
1345 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1346 b->posn = PerlIO_tell(PerlIONext(f));
1352 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1354 PerlIO *next = PerlIONext(f);
1355 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1357 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1360 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1361 b->posn = PerlIO_tell(PerlIONext(f));
1366 /* This "flush" is akin to sfio's sync in that it handles files in either
1370 PerlIOBuf_flush(PerlIO *f)
1372 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1374 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1376 /* write() the buffer */
1377 STDCHAR *p = b->buf;
1381 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1388 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1393 b->posn += (p - b->buf);
1395 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1397 /* Note position change */
1398 b->posn += (b->ptr - b->buf);
1399 if (b->ptr < b->end)
1401 /* We did not consume all of it */
1402 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1404 b->posn = PerlIO_tell(PerlIONext(f));
1408 b->ptr = b->end = b->buf;
1409 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1410 if (PerlIO_flush(PerlIONext(f)) != 0)
1416 PerlIOBuf_fill(PerlIO *f)
1418 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1420 if (PerlIO_flush(f) != 0)
1422 b->ptr = b->end = b->buf;
1423 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1427 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1429 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1432 b->end = b->buf+avail;
1433 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1438 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1440 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1441 STDCHAR *buf = (STDCHAR *) vbuf;
1447 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1451 SSize_t avail = (b->end - b->ptr);
1452 if ((SSize_t) count < avail)
1456 Copy(b->ptr,buf,avail,char);
1462 if (count && (b->ptr >= b->end))
1464 if (PerlIO_fill(f) != 0)
1474 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1476 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1477 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1480 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1486 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1488 avail = (b->ptr - b->buf);
1489 if (avail > (SSize_t) count)
1496 if (avail > (SSize_t) count)
1498 b->end = b->ptr + avail;
1505 Copy(buf,b->ptr,avail,char);
1509 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1516 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1518 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1519 const STDCHAR *buf = (const STDCHAR *) vbuf;
1523 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1527 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1528 if ((SSize_t) count < avail)
1530 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1531 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1551 Copy(buf,b->ptr,avail,char);
1558 if (b->ptr >= (b->buf + b->bufsiz))
1565 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1567 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1568 int code = PerlIO_flush(f);
1571 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1572 code = PerlIO_seek(PerlIONext(f),offset,whence);
1575 b->posn = PerlIO_tell(PerlIONext(f));
1582 PerlIOBuf_tell(PerlIO *f)
1584 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1585 Off_t posn = b->posn;
1587 posn += (b->ptr - b->buf);
1592 PerlIOBuf_close(PerlIO *f)
1594 IV code = PerlIOBase_close(f);
1595 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1596 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1601 b->ptr = b->end = b->buf;
1602 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1607 PerlIOBuf_setlinebuf(PerlIO *f)
1611 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1616 PerlIOBuf_get_ptr(PerlIO *f)
1618 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1625 PerlIOBuf_get_cnt(PerlIO *f)
1627 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1630 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1631 return (b->end - b->ptr);
1636 PerlIOBuf_get_base(PerlIO *f)
1638 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1643 New('B',b->buf,b->bufsiz,STDCHAR);
1646 b->buf = (STDCHAR *)&b->oneword;
1647 b->bufsiz = sizeof(b->oneword);
1656 PerlIOBuf_bufsiz(PerlIO *f)
1658 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1661 return (b->end - b->buf);
1665 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1667 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1671 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1674 assert(PerlIO_get_cnt(f) == cnt);
1675 assert(b->ptr >= b->buf);
1677 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1680 PerlIO_funcs PerlIO_perlio = {
1700 PerlIOBase_clearerr,
1701 PerlIOBuf_setlinebuf,
1706 PerlIOBuf_set_ptrcnt,
1710 /*--------------------------------------------------------------------------------------*/
1711 /* mmap as "buffer" layer */
1715 PerlIOBuf base; /* PerlIOBuf stuff */
1716 Mmap_t mptr; /* Mapped address */
1717 Size_t len; /* mapped length */
1718 STDCHAR *bbuf; /* malloced buffer if map fails */
1722 static size_t page_size = 0;
1725 PerlIOMmap_map(PerlIO *f)
1728 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1729 PerlIOBuf *b = &m->base;
1730 IV flags = PerlIOBase(f)->flags;
1734 if (flags & PERLIO_F_CANREAD)
1736 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1737 int fd = PerlIO_fileno(f);
1739 code = fstat(fd,&st);
1740 if (code == 0 && S_ISREG(st.st_mode))
1742 SSize_t len = st.st_size - b->posn;
1747 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1749 SETERRNO(0,SS$_NORMAL);
1750 # ifdef _SC_PAGESIZE
1751 page_size = sysconf(_SC_PAGESIZE);
1753 page_size = sysconf(_SC_PAGE_SIZE);
1755 if ((long)page_size < 0) {
1760 (void)SvUPGRADE(error, SVt_PV);
1761 msg = SvPVx(error, n_a);
1762 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1765 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1769 # ifdef HAS_GETPAGESIZE
1770 page_size = getpagesize();
1772 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
1773 page_size = PAGESIZE; /* compiletime, bad */
1777 if ((IV)page_size <= 0)
1778 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1782 /* This is a hack - should never happen - open should have set it ! */
1783 b->posn = PerlIO_tell(PerlIONext(f));
1785 posn = (b->posn / page_size) * page_size;
1786 len = st.st_size - posn;
1787 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1788 if (m->mptr && m->mptr != (Mmap_t) -1)
1790 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1791 madvise(m->mptr, len, MADV_SEQUENTIAL);
1793 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1794 b->end = ((STDCHAR *)m->mptr) + len;
1795 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
1806 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1808 b->ptr = b->end = b->ptr;
1817 PerlIOMmap_unmap(PerlIO *f)
1819 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1820 PerlIOBuf *b = &m->base;
1826 code = munmap(m->mptr, m->len);
1830 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1833 b->ptr = b->end = b->buf;
1834 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1840 PerlIOMmap_get_base(PerlIO *f)
1842 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1843 PerlIOBuf *b = &m->base;
1844 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1846 /* Already have a readbuffer in progress */
1851 /* We have a write buffer or flushed PerlIOBuf read buffer */
1852 m->bbuf = b->buf; /* save it in case we need it again */
1853 b->buf = NULL; /* Clear to trigger below */
1857 PerlIOMmap_map(f); /* Try and map it */
1860 /* Map did not work - recover PerlIOBuf buffer if we have one */
1864 b->ptr = b->end = b->buf;
1867 return PerlIOBuf_get_base(f);
1871 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
1873 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1874 PerlIOBuf *b = &m->base;
1875 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1877 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
1880 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1885 /* Loose the unwritable mapped buffer */
1887 /* If flush took the "buffer" see if we have one from before */
1888 if (!b->buf && m->bbuf)
1892 PerlIOBuf_get_base(f);
1896 return PerlIOBuf_unread(f,vbuf,count);
1900 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
1902 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1903 PerlIOBuf *b = &m->base;
1904 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
1906 /* No, or wrong sort of, buffer */
1909 if (PerlIOMmap_unmap(f) != 0)
1912 /* If unmap took the "buffer" see if we have one from before */
1913 if (!b->buf && m->bbuf)
1917 PerlIOBuf_get_base(f);
1921 return PerlIOBuf_write(f,vbuf,count);
1925 PerlIOMmap_flush(PerlIO *f)
1927 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1928 PerlIOBuf *b = &m->base;
1929 IV code = PerlIOBuf_flush(f);
1930 /* Now we are "synced" at PerlIOBuf level */
1935 /* Unmap the buffer */
1936 if (PerlIOMmap_unmap(f) != 0)
1941 /* We seem to have a PerlIOBuf buffer which was not mapped
1942 * remember it in case we need one later
1951 PerlIOMmap_fill(PerlIO *f)
1953 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1954 IV code = PerlIO_flush(f);
1955 if (code == 0 && !b->buf)
1957 code = PerlIOMmap_map(f);
1959 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1961 code = PerlIOBuf_fill(f);
1967 PerlIOMmap_close(PerlIO *f)
1969 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1970 PerlIOBuf *b = &m->base;
1971 IV code = PerlIO_flush(f);
1976 b->ptr = b->end = b->buf;
1978 if (PerlIOBuf_close(f) != 0)
1984 PerlIO_funcs PerlIO_mmap = {
2004 PerlIOBase_clearerr,
2005 PerlIOBuf_setlinebuf,
2006 PerlIOMmap_get_base,
2010 PerlIOBuf_set_ptrcnt,
2013 #endif /* HAS_MMAP */
2020 atexit(&PerlIO_cleanup);
2029 PerlIO_stdstreams();
2033 #undef PerlIO_stdout
2038 PerlIO_stdstreams();
2042 #undef PerlIO_stderr
2047 PerlIO_stdstreams();
2051 /*--------------------------------------------------------------------------------------*/
2053 #undef PerlIO_getname
2055 PerlIO_getname(PerlIO *f, char *buf)
2058 Perl_croak(aTHX_ "Don't know how to get file name");
2063 /*--------------------------------------------------------------------------------------*/
2064 /* Functions which can be called on any kind of PerlIO implemented
2070 PerlIO_getc(PerlIO *f)
2073 SSize_t count = PerlIO_read(f,buf,1);
2076 return (unsigned char) buf[0];
2081 #undef PerlIO_ungetc
2083 PerlIO_ungetc(PerlIO *f, int ch)
2088 if (PerlIO_unread(f,&buf,1) == 1)
2096 PerlIO_putc(PerlIO *f, int ch)
2099 return PerlIO_write(f,&buf,1);
2104 PerlIO_puts(PerlIO *f, const char *s)
2106 STRLEN len = strlen(s);
2107 return PerlIO_write(f,s,len);
2110 #undef PerlIO_rewind
2112 PerlIO_rewind(PerlIO *f)
2114 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2118 #undef PerlIO_vprintf
2120 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2123 SV *sv = newSVpvn("",0);
2126 sv_vcatpvf(sv, fmt, &ap);
2128 return PerlIO_write(f,s,len);
2131 #undef PerlIO_printf
2133 PerlIO_printf(PerlIO *f,const char *fmt,...)
2138 result = PerlIO_vprintf(f,fmt,ap);
2143 #undef PerlIO_stdoutf
2145 PerlIO_stdoutf(const char *fmt,...)
2150 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2155 #undef PerlIO_tmpfile
2157 PerlIO_tmpfile(void)
2160 /* I have no idea how portable mkstemp() is ... */
2161 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2162 int fd = mkstemp(SvPVX(sv));
2166 f = PerlIO_fdopen(fd,"w+");
2169 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2171 PerlLIO_unlink(SvPVX(sv));
2180 #endif /* USE_SFIO */
2181 #endif /* PERLIO_IS_STDIO */
2183 /*======================================================================================*/
2184 /* Now some functions in terms of above which may be needed even if
2185 we are not in true PerlIO mode
2189 #undef PerlIO_setpos
2191 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2193 return PerlIO_seek(f,*pos,0);
2196 #ifndef PERLIO_IS_STDIO
2197 #undef PerlIO_setpos
2199 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2201 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2202 return fsetpos64(f, pos);
2204 return fsetpos(f, pos);
2211 #undef PerlIO_getpos
2213 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2215 *pos = PerlIO_tell(f);
2216 return *pos == -1 ? -1 : 0;
2219 #ifndef PERLIO_IS_STDIO
2220 #undef PerlIO_getpos
2222 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2224 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2225 return fgetpos64(f, pos);
2227 return fgetpos(f, pos);
2233 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2236 vprintf(char *pat, char *args)
2238 _doprnt(pat, args, stdout);
2239 return 0; /* wrong, but perl doesn't use the return value */
2243 vfprintf(FILE *fd, char *pat, char *args)
2245 _doprnt(pat, args, fd);
2246 return 0; /* wrong, but perl doesn't use the return value */
2251 #ifndef PerlIO_vsprintf
2253 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2255 int val = vsprintf(s, fmt, ap);
2258 if (strlen(s) >= (STRLEN)n)
2261 (void)PerlIO_puts(Perl_error_log,
2262 "panic: sprintf overflow - memory corrupted!\n");
2270 #ifndef PerlIO_sprintf
2272 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2277 result = PerlIO_vsprintf(s, n, fmt, ap);
2283 #endif /* !PERL_IMPLICIT_SYS */