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);
211 /*--------------------------------------------------------------------------------------*/
212 /* XS Interface for perl code */
218 char *s = GvNAME(gv);
219 STRLEN l = GvNAMELEN(gv);
220 PerlIO_debug("%.*s\n",(int) l,s);
224 XS(XS_perlio_unimport)
228 char *s = GvNAME(gv);
229 STRLEN l = GvNAMELEN(gv);
230 PerlIO_debug("%.*s\n",(int) l,s);
235 PerlIO_find_layer(char *name, STRLEN len)
242 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
243 if (svp && (sv = *svp) && SvROK(sv))
250 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
254 IO *io = GvIOn((GV *)SvRV(sv));
255 PerlIO *ifp = IoIFP(io);
256 PerlIO *ofp = IoOFP(io);
257 AV *av = (AV *) mg->mg_obj;
258 Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
264 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
268 IO *io = GvIOn((GV *)SvRV(sv));
269 PerlIO *ifp = IoIFP(io);
270 PerlIO *ofp = IoOFP(io);
271 AV *av = (AV *) mg->mg_obj;
272 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
278 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
280 Perl_warn(aTHX_ "clear %_",sv);
285 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
287 Perl_warn(aTHX_ "free %_",sv);
291 MGVTBL perlio_vtab = {
299 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
302 SV *sv = SvRV(ST(1));
307 sv_magic(sv, (SV *)av, '~', NULL, 0);
309 mg = mg_find(sv,'~');
310 mg->mg_virtual = &perlio_vtab;
312 Perl_warn(aTHX_ "attrib %_",sv);
313 for (i=2; i < items; i++)
316 char *name = SvPV(ST(i),len);
317 SV *layer = PerlIO_find_layer(name,len);
320 av_push(av,SvREFCNT_inc(layer));
333 PerlIO_define_layer(PerlIO_funcs *tab)
336 HV *stash = gv_stashpv("perlio::Layer", TRUE);
337 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
338 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
342 PerlIO_default_layer(I32 n)
347 PerlIO_funcs *tab = &PerlIO_stdio;
349 if (!PerlIO_layer_hv)
351 char *s = PerlEnv_getenv("PERLIO");
352 newXS("perlio::import",XS_perlio_import,__FILE__);
353 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
355 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
357 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
358 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
359 PerlIO_define_layer(&PerlIO_unix);
360 PerlIO_define_layer(&PerlIO_perlio);
361 PerlIO_define_layer(&PerlIO_stdio);
363 PerlIO_define_layer(&PerlIO_mmap);
365 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
370 while (*s && isSPACE((unsigned char)*s))
376 while (*e && !isSPACE((unsigned char)*e))
378 layer = PerlIO_find_layer(s,e-s);
381 PerlIO_debug("Pushing %.*s\n",(e-s),s);
382 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
385 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
391 len = av_len(PerlIO_layer_av);
394 if (PerlIO_stdio.Set_ptrcnt)
396 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
400 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
402 len = av_len(PerlIO_layer_av);
406 svp = av_fetch(PerlIO_layer_av,n,0);
407 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
409 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
411 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
415 #define PerlIO_default_top() PerlIO_default_layer(-1)
416 #define PerlIO_default_btm() PerlIO_default_layer(0)
424 PerlIO_fdopen(0,"Ir");
425 PerlIO_fdopen(1,"Iw");
426 PerlIO_fdopen(2,"Iw");
431 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
434 Newc('L',l,tab->size,char,PerlIOl);
437 Zero(l,tab->size,char);
441 if ((*l->tab->Pushed)(f,mode) != 0)
450 /*--------------------------------------------------------------------------------------*/
451 /* Given the abstraction above the public API functions */
455 PerlIO_close(PerlIO *f)
457 int code = (*PerlIOBase(f)->tab->Close)(f);
467 PerlIO_fileno(PerlIO *f)
469 return (*PerlIOBase(f)->tab->Fileno)(f);
476 PerlIO_fdopen(int fd, const char *mode)
478 PerlIO_funcs *tab = PerlIO_default_top();
481 return (*tab->Fdopen)(tab,fd,mode);
486 PerlIO_open(const char *path, const char *mode)
488 PerlIO_funcs *tab = PerlIO_default_top();
491 return (*tab->Open)(tab,path,mode);
496 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
501 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
503 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
509 return PerlIO_open(path,mode);
514 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
516 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
521 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
523 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
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_fill(PerlIO *f)
578 return (*PerlIOBase(f)->tab->Fill)(f);
583 PerlIO_isutf8(PerlIO *f)
585 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
590 PerlIO_eof(PerlIO *f)
592 return (*PerlIOBase(f)->tab->Eof)(f);
597 PerlIO_error(PerlIO *f)
599 return (*PerlIOBase(f)->tab->Error)(f);
602 #undef PerlIO_clearerr
604 PerlIO_clearerr(PerlIO *f)
606 (*PerlIOBase(f)->tab->Clearerr)(f);
609 #undef PerlIO_setlinebuf
611 PerlIO_setlinebuf(PerlIO *f)
613 (*PerlIOBase(f)->tab->Setlinebuf)(f);
616 #undef PerlIO_has_base
618 PerlIO_has_base(PerlIO *f)
622 return (PerlIOBase(f)->tab->Get_base != NULL);
627 #undef PerlIO_fast_gets
629 PerlIO_fast_gets(PerlIO *f)
633 PerlIOl *l = PerlIOBase(f);
634 return (l->tab->Set_ptrcnt != NULL);
639 #undef PerlIO_has_cntptr
641 PerlIO_has_cntptr(PerlIO *f)
645 PerlIO_funcs *tab = PerlIOBase(f)->tab;
646 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
651 #undef PerlIO_canset_cnt
653 PerlIO_canset_cnt(PerlIO *f)
657 PerlIOl *l = PerlIOBase(f);
658 return (l->tab->Set_ptrcnt != NULL);
663 #undef PerlIO_get_base
665 PerlIO_get_base(PerlIO *f)
667 return (*PerlIOBase(f)->tab->Get_base)(f);
670 #undef PerlIO_get_bufsiz
672 PerlIO_get_bufsiz(PerlIO *f)
674 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
677 #undef PerlIO_get_ptr
679 PerlIO_get_ptr(PerlIO *f)
681 return (*PerlIOBase(f)->tab->Get_ptr)(f);
684 #undef PerlIO_get_cnt
686 PerlIO_get_cnt(PerlIO *f)
688 return (*PerlIOBase(f)->tab->Get_cnt)(f);
691 #undef PerlIO_set_cnt
693 PerlIO_set_cnt(PerlIO *f,int cnt)
695 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
698 #undef PerlIO_set_ptrcnt
700 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
702 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
705 /*--------------------------------------------------------------------------------------*/
706 /* "Methods" of the "base class" */
709 PerlIOBase_fileno(PerlIO *f)
711 return PerlIO_fileno(PerlIONext(f));
715 PerlIOBase_pushed(PerlIO *f, const char *mode)
717 PerlIOl *l = PerlIOBase(f);
718 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
719 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
725 l->flags = PERLIO_F_CANREAD;
728 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
731 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
742 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
745 l->flags |= PERLIO_F_BINARY;
757 l->flags |= l->next->flags &
758 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
759 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
766 PerlIOBase_popped(PerlIO *f)
772 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
774 Off_t old = PerlIO_tell(f);
775 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
777 Off_t new = PerlIO_tell(f);
784 PerlIOBase_noop_ok(PerlIO *f)
790 PerlIOBase_noop_fail(PerlIO *f)
796 PerlIOBase_close(PerlIO *f)
799 if (PerlIO_flush(f) != 0)
801 if (PerlIO_close(PerlIONext(f)) != 0)
803 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
808 PerlIOBase_eof(PerlIO *f)
812 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
818 PerlIOBase_error(PerlIO *f)
822 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
828 PerlIOBase_clearerr(PerlIO *f)
832 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
837 PerlIOBase_setlinebuf(PerlIO *f)
842 /*--------------------------------------------------------------------------------------*/
843 /* Bottom-most level for UNIX-like case */
847 struct _PerlIO base; /* The generic part */
848 int fd; /* UNIX like file descriptor */
849 int oflags; /* open/fcntl flags */
853 PerlIOUnix_oflags(const char *mode)
868 oflags = O_CREAT|O_TRUNC;
879 oflags = O_CREAT|O_APPEND;
889 if (*mode || oflags == -1)
898 PerlIOUnix_fileno(PerlIO *f)
900 return PerlIOSelf(f,PerlIOUnix)->fd;
904 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
911 int oflags = PerlIOUnix_oflags(mode);
914 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
917 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
924 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
927 int oflags = PerlIOUnix_oflags(mode);
930 int fd = PerlLIO_open3(path,oflags,0666);
933 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
936 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
943 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
945 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
946 int oflags = PerlIOUnix_oflags(mode);
947 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
948 (*PerlIOBase(f)->tab->Close)(f);
951 int fd = PerlLIO_open3(path,oflags,0666);
956 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
964 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
966 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
967 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
971 SSize_t len = PerlLIO_read(fd,vbuf,count);
972 if (len >= 0 || errno != EINTR)
975 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
976 else if (len == 0 && count != 0)
977 PerlIOBase(f)->flags |= PERLIO_F_EOF;
984 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
986 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
989 SSize_t len = PerlLIO_write(fd,vbuf,count);
990 if (len >= 0 || errno != EINTR)
993 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1000 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1002 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1003 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1004 return (new == (Off_t) -1) ? -1 : 0;
1008 PerlIOUnix_tell(PerlIO *f)
1010 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1014 PerlIOUnix_close(PerlIO *f)
1016 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1018 while (PerlLIO_close(fd) != 0)
1028 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1033 PerlIO_funcs PerlIO_unix = {
1049 PerlIOBase_noop_ok, /* flush */
1050 PerlIOBase_noop_fail, /* fill */
1053 PerlIOBase_clearerr,
1054 PerlIOBase_setlinebuf,
1055 NULL, /* get_base */
1056 NULL, /* get_bufsiz */
1059 NULL, /* set_ptrcnt */
1062 /*--------------------------------------------------------------------------------------*/
1063 /* stdio as a layer */
1067 struct _PerlIO base;
1068 FILE * stdio; /* The stream */
1072 PerlIOStdio_fileno(PerlIO *f)
1074 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1079 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1107 stdio = fdopen(fd,mode);
1110 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1117 #undef PerlIO_importFILE
1119 PerlIO_importFILE(FILE *stdio, int fl)
1124 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1131 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1134 FILE *stdio = fopen(path,mode);
1137 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1144 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1146 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1147 FILE *stdio = freopen(path,mode,s->stdio);
1155 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1157 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1161 STDCHAR *buf = (STDCHAR *) vbuf;
1162 /* Perl is expecting PerlIO_getc() to fill the buffer
1163 * Linux's stdio does not do that for fread()
1173 got = fread(vbuf,1,count,s);
1178 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1180 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1181 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1185 int ch = *buf-- & 0xff;
1186 if (ungetc(ch,s) != ch)
1195 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1197 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1201 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1203 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1204 return fseek(stdio,offset,whence);
1208 PerlIOStdio_tell(PerlIO *f)
1210 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1211 return ftell(stdio);
1215 PerlIOStdio_close(PerlIO *f)
1217 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1221 PerlIOStdio_flush(PerlIO *f)
1223 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1224 return fflush(stdio);
1228 PerlIOStdio_fill(PerlIO *f)
1230 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1232 if (fflush(stdio) != 0)
1235 if (c == EOF || ungetc(c,stdio) != c)
1241 PerlIOStdio_eof(PerlIO *f)
1243 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1247 PerlIOStdio_error(PerlIO *f)
1249 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1253 PerlIOStdio_clearerr(PerlIO *f)
1255 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1259 PerlIOStdio_setlinebuf(PerlIO *f)
1261 #ifdef HAS_SETLINEBUF
1262 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1264 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1270 PerlIOStdio_get_base(PerlIO *f)
1272 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1273 return FILE_base(stdio);
1277 PerlIOStdio_get_bufsiz(PerlIO *f)
1279 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1280 return FILE_bufsiz(stdio);
1284 #ifdef USE_STDIO_PTR
1286 PerlIOStdio_get_ptr(PerlIO *f)
1288 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1289 return FILE_ptr(stdio);
1293 PerlIOStdio_get_cnt(PerlIO *f)
1295 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1296 return FILE_cnt(stdio);
1300 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1302 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1305 #ifdef STDIO_PTR_LVALUE
1306 FILE_ptr(stdio) = ptr;
1307 #ifdef STDIO_PTR_LVAL_SETS_CNT
1308 if (FILE_cnt(stdio) != (cnt))
1311 assert(FILE_cnt(stdio) == (cnt));
1314 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1315 /* Setting ptr _does_ change cnt - we are done */
1318 #else /* STDIO_PTR_LVALUE */
1320 #endif /* STDIO_PTR_LVALUE */
1322 /* Now (or only) set cnt */
1323 #ifdef STDIO_CNT_LVALUE
1324 FILE_cnt(stdio) = cnt;
1325 #else /* STDIO_CNT_LVALUE */
1326 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1327 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1328 #else /* STDIO_PTR_LVAL_SETS_CNT */
1330 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1331 #endif /* STDIO_CNT_LVALUE */
1336 PerlIO_funcs PerlIO_stdio = {
1338 sizeof(PerlIOStdio),
1356 PerlIOStdio_clearerr,
1357 PerlIOStdio_setlinebuf,
1359 PerlIOStdio_get_base,
1360 PerlIOStdio_get_bufsiz,
1365 #ifdef USE_STDIO_PTR
1366 PerlIOStdio_get_ptr,
1367 PerlIOStdio_get_cnt,
1368 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1369 PerlIOStdio_set_ptrcnt
1370 #else /* STDIO_PTR_LVALUE */
1372 #endif /* STDIO_PTR_LVALUE */
1373 #else /* USE_STDIO_PTR */
1377 #endif /* USE_STDIO_PTR */
1380 #undef PerlIO_exportFILE
1382 PerlIO_exportFILE(PerlIO *f, int fl)
1385 /* Should really push stdio discipline when we have them */
1386 return fdopen(PerlIO_fileno(f),"r+");
1389 #undef PerlIO_findFILE
1391 PerlIO_findFILE(PerlIO *f)
1393 return PerlIO_exportFILE(f,0);
1396 #undef PerlIO_releaseFILE
1398 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1402 /*--------------------------------------------------------------------------------------*/
1403 /* perlio buffer layer */
1406 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1408 PerlIO_funcs *tab = PerlIO_default_btm();
1416 f = (*tab->Fdopen)(tab,fd,mode);
1419 /* Initial stderr is unbuffered */
1420 if (!init || fd != 2)
1422 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1423 b->posn = PerlIO_tell(PerlIONext(f));
1430 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1432 PerlIO_funcs *tab = PerlIO_default_btm();
1433 PerlIO *f = (*tab->Open)(tab,path,mode);
1436 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1437 b->posn = PerlIO_tell(PerlIONext(f));
1443 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1445 PerlIO *next = PerlIONext(f);
1446 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1448 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1451 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1452 b->posn = PerlIO_tell(PerlIONext(f));
1457 /* This "flush" is akin to sfio's sync in that it handles files in either
1461 PerlIOBuf_flush(PerlIO *f)
1463 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1465 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1467 /* write() the buffer */
1468 STDCHAR *p = b->buf;
1472 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1479 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1484 b->posn += (p - b->buf);
1486 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1488 /* Note position change */
1489 b->posn += (b->ptr - b->buf);
1490 if (b->ptr < b->end)
1492 /* We did not consume all of it */
1493 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1495 b->posn = PerlIO_tell(PerlIONext(f));
1499 b->ptr = b->end = b->buf;
1500 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1501 if (PerlIO_flush(PerlIONext(f)) != 0)
1507 PerlIOBuf_fill(PerlIO *f)
1509 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1511 if (PerlIO_flush(f) != 0)
1513 b->ptr = b->end = b->buf;
1514 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1518 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1520 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1523 b->end = b->buf+avail;
1524 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1529 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1531 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1532 STDCHAR *buf = (STDCHAR *) vbuf;
1538 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1542 SSize_t avail = (b->end - b->ptr);
1543 if ((SSize_t) count < avail)
1547 Copy(b->ptr,buf,avail,char);
1553 if (count && (b->ptr >= b->end))
1555 if (PerlIO_fill(f) != 0)
1565 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1567 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1568 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1571 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1577 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1579 avail = (b->ptr - b->buf);
1580 if (avail > (SSize_t) count)
1587 if (avail > (SSize_t) count)
1589 b->end = b->ptr + avail;
1596 Copy(buf,b->ptr,avail,char);
1600 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1607 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1609 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1610 const STDCHAR *buf = (const STDCHAR *) vbuf;
1614 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1618 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1619 if ((SSize_t) count < avail)
1621 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1622 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1642 Copy(buf,b->ptr,avail,char);
1649 if (b->ptr >= (b->buf + b->bufsiz))
1656 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1658 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1659 int code = PerlIO_flush(f);
1662 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1663 code = PerlIO_seek(PerlIONext(f),offset,whence);
1666 b->posn = PerlIO_tell(PerlIONext(f));
1673 PerlIOBuf_tell(PerlIO *f)
1675 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1676 Off_t posn = b->posn;
1678 posn += (b->ptr - b->buf);
1683 PerlIOBuf_close(PerlIO *f)
1685 IV code = PerlIOBase_close(f);
1686 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1687 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1692 b->ptr = b->end = b->buf;
1693 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1698 PerlIOBuf_setlinebuf(PerlIO *f)
1702 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1707 PerlIOBuf_get_ptr(PerlIO *f)
1709 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1716 PerlIOBuf_get_cnt(PerlIO *f)
1718 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1721 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1722 return (b->end - b->ptr);
1727 PerlIOBuf_get_base(PerlIO *f)
1729 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1734 New('B',b->buf,b->bufsiz,STDCHAR);
1737 b->buf = (STDCHAR *)&b->oneword;
1738 b->bufsiz = sizeof(b->oneword);
1747 PerlIOBuf_bufsiz(PerlIO *f)
1749 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1752 return (b->end - b->buf);
1756 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1758 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1762 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1765 assert(PerlIO_get_cnt(f) == cnt);
1766 assert(b->ptr >= b->buf);
1768 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1771 PerlIO_funcs PerlIO_perlio = {
1791 PerlIOBase_clearerr,
1792 PerlIOBuf_setlinebuf,
1797 PerlIOBuf_set_ptrcnt,
1801 /*--------------------------------------------------------------------------------------*/
1802 /* mmap as "buffer" layer */
1806 PerlIOBuf base; /* PerlIOBuf stuff */
1807 Mmap_t mptr; /* Mapped address */
1808 Size_t len; /* mapped length */
1809 STDCHAR *bbuf; /* malloced buffer if map fails */
1813 static size_t page_size = 0;
1816 PerlIOMmap_map(PerlIO *f)
1819 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1820 PerlIOBuf *b = &m->base;
1821 IV flags = PerlIOBase(f)->flags;
1825 if (flags & PERLIO_F_CANREAD)
1827 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1828 int fd = PerlIO_fileno(f);
1830 code = fstat(fd,&st);
1831 if (code == 0 && S_ISREG(st.st_mode))
1833 SSize_t len = st.st_size - b->posn;
1838 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1840 SETERRNO(0,SS$_NORMAL);
1841 # ifdef _SC_PAGESIZE
1842 page_size = sysconf(_SC_PAGESIZE);
1844 page_size = sysconf(_SC_PAGE_SIZE);
1846 if ((long)page_size < 0) {
1851 (void)SvUPGRADE(error, SVt_PV);
1852 msg = SvPVx(error, n_a);
1853 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1856 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1860 # ifdef HAS_GETPAGESIZE
1861 page_size = getpagesize();
1863 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
1864 page_size = PAGESIZE; /* compiletime, bad */
1868 if ((IV)page_size <= 0)
1869 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1873 /* This is a hack - should never happen - open should have set it ! */
1874 b->posn = PerlIO_tell(PerlIONext(f));
1876 posn = (b->posn / page_size) * page_size;
1877 len = st.st_size - posn;
1878 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1879 if (m->mptr && m->mptr != (Mmap_t) -1)
1881 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1882 madvise(m->mptr, len, MADV_SEQUENTIAL);
1884 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1885 b->end = ((STDCHAR *)m->mptr) + len;
1886 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
1897 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1899 b->ptr = b->end = b->ptr;
1908 PerlIOMmap_unmap(PerlIO *f)
1910 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1911 PerlIOBuf *b = &m->base;
1917 code = munmap(m->mptr, m->len);
1921 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1924 b->ptr = b->end = b->buf;
1925 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1931 PerlIOMmap_get_base(PerlIO *f)
1933 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1934 PerlIOBuf *b = &m->base;
1935 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1937 /* Already have a readbuffer in progress */
1942 /* We have a write buffer or flushed PerlIOBuf read buffer */
1943 m->bbuf = b->buf; /* save it in case we need it again */
1944 b->buf = NULL; /* Clear to trigger below */
1948 PerlIOMmap_map(f); /* Try and map it */
1951 /* Map did not work - recover PerlIOBuf buffer if we have one */
1955 b->ptr = b->end = b->buf;
1958 return PerlIOBuf_get_base(f);
1962 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
1964 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1965 PerlIOBuf *b = &m->base;
1966 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1968 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
1971 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1976 /* Loose the unwritable mapped buffer */
1978 /* If flush took the "buffer" see if we have one from before */
1979 if (!b->buf && m->bbuf)
1983 PerlIOBuf_get_base(f);
1987 return PerlIOBuf_unread(f,vbuf,count);
1991 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
1993 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1994 PerlIOBuf *b = &m->base;
1995 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
1997 /* No, or wrong sort of, buffer */
2000 if (PerlIOMmap_unmap(f) != 0)
2003 /* If unmap took the "buffer" see if we have one from before */
2004 if (!b->buf && m->bbuf)
2008 PerlIOBuf_get_base(f);
2012 return PerlIOBuf_write(f,vbuf,count);
2016 PerlIOMmap_flush(PerlIO *f)
2018 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2019 PerlIOBuf *b = &m->base;
2020 IV code = PerlIOBuf_flush(f);
2021 /* Now we are "synced" at PerlIOBuf level */
2026 /* Unmap the buffer */
2027 if (PerlIOMmap_unmap(f) != 0)
2032 /* We seem to have a PerlIOBuf buffer which was not mapped
2033 * remember it in case we need one later
2042 PerlIOMmap_fill(PerlIO *f)
2044 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2045 IV code = PerlIO_flush(f);
2046 if (code == 0 && !b->buf)
2048 code = PerlIOMmap_map(f);
2050 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2052 code = PerlIOBuf_fill(f);
2058 PerlIOMmap_close(PerlIO *f)
2060 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2061 PerlIOBuf *b = &m->base;
2062 IV code = PerlIO_flush(f);
2067 b->ptr = b->end = b->buf;
2069 if (PerlIOBuf_close(f) != 0)
2075 PerlIO_funcs PerlIO_mmap = {
2095 PerlIOBase_clearerr,
2096 PerlIOBuf_setlinebuf,
2097 PerlIOMmap_get_base,
2101 PerlIOBuf_set_ptrcnt,
2104 #endif /* HAS_MMAP */
2111 atexit(&PerlIO_cleanup);
2120 PerlIO_stdstreams();
2124 #undef PerlIO_stdout
2129 PerlIO_stdstreams();
2133 #undef PerlIO_stderr
2138 PerlIO_stdstreams();
2142 /*--------------------------------------------------------------------------------------*/
2144 #undef PerlIO_getname
2146 PerlIO_getname(PerlIO *f, char *buf)
2149 Perl_croak(aTHX_ "Don't know how to get file name");
2154 /*--------------------------------------------------------------------------------------*/
2155 /* Functions which can be called on any kind of PerlIO implemented
2161 PerlIO_getc(PerlIO *f)
2164 SSize_t count = PerlIO_read(f,buf,1);
2167 return (unsigned char) buf[0];
2172 #undef PerlIO_ungetc
2174 PerlIO_ungetc(PerlIO *f, int ch)
2179 if (PerlIO_unread(f,&buf,1) == 1)
2187 PerlIO_putc(PerlIO *f, int ch)
2190 return PerlIO_write(f,&buf,1);
2195 PerlIO_puts(PerlIO *f, const char *s)
2197 STRLEN len = strlen(s);
2198 return PerlIO_write(f,s,len);
2201 #undef PerlIO_rewind
2203 PerlIO_rewind(PerlIO *f)
2205 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2209 #undef PerlIO_vprintf
2211 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2214 SV *sv = newSVpvn("",0);
2217 sv_vcatpvf(sv, fmt, &ap);
2219 return PerlIO_write(f,s,len);
2222 #undef PerlIO_printf
2224 PerlIO_printf(PerlIO *f,const char *fmt,...)
2229 result = PerlIO_vprintf(f,fmt,ap);
2234 #undef PerlIO_stdoutf
2236 PerlIO_stdoutf(const char *fmt,...)
2241 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2246 #undef PerlIO_tmpfile
2248 PerlIO_tmpfile(void)
2251 /* I have no idea how portable mkstemp() is ... */
2252 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2253 int fd = mkstemp(SvPVX(sv));
2257 f = PerlIO_fdopen(fd,"w+");
2260 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2262 PerlLIO_unlink(SvPVX(sv));
2271 #endif /* USE_SFIO */
2272 #endif /* PERLIO_IS_STDIO */
2274 /*======================================================================================*/
2275 /* Now some functions in terms of above which may be needed even if
2276 we are not in true PerlIO mode
2280 #undef PerlIO_setpos
2282 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2284 return PerlIO_seek(f,*pos,0);
2287 #ifndef PERLIO_IS_STDIO
2288 #undef PerlIO_setpos
2290 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2292 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2293 return fsetpos64(f, pos);
2295 return fsetpos(f, pos);
2302 #undef PerlIO_getpos
2304 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2306 *pos = PerlIO_tell(f);
2307 return *pos == -1 ? -1 : 0;
2310 #ifndef PERLIO_IS_STDIO
2311 #undef PerlIO_getpos
2313 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2315 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2316 return fgetpos64(f, pos);
2318 return fgetpos(f, pos);
2324 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2327 vprintf(char *pat, char *args)
2329 _doprnt(pat, args, stdout);
2330 return 0; /* wrong, but perl doesn't use the return value */
2334 vfprintf(FILE *fd, char *pat, char *args)
2336 _doprnt(pat, args, fd);
2337 return 0; /* wrong, but perl doesn't use the return value */
2342 #ifndef PerlIO_vsprintf
2344 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2346 int val = vsprintf(s, fmt, ap);
2349 if (strlen(s) >= (STRLEN)n)
2352 (void)PerlIO_puts(Perl_error_log,
2353 "panic: sprintf overflow - memory corrupted!\n");
2361 #ifndef PerlIO_sprintf
2363 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2368 result = PerlIO_vsprintf(s, n, fmt, ap);
2374 #endif /* !PERL_IMPLICIT_SYS */