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);
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))
270 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
274 IO *io = GvIOn(SvRV(sv));
275 PerlIO *ifp = IoIFP(io);
276 PerlIO *ofp = IoOFP(io);
277 AV *av = (AV *) mg->mg_obj;
278 Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
284 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
288 IO *io = GvIOn(SvRV(sv));
289 PerlIO *ifp = IoIFP(io);
290 PerlIO *ofp = IoOFP(io);
291 AV *av = (AV *) mg->mg_obj;
292 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
298 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
300 Perl_warn(aTHX_ "clear %_",sv);
305 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
307 Perl_warn(aTHX_ "free %_",sv);
311 MGVTBL perlio_vtab = {
319 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
322 SV *sv = SvRV(ST(1));
327 sv_magic(sv, (SV *)av, '~', NULL, 0);
329 mg = mg_find(sv,'~');
330 mg->mg_virtual = &perlio_vtab;
332 Perl_warn(aTHX_ "attrib %_",sv);
333 for (i=2; i < items; i++)
336 char *name = SvPV(ST(i),len);
337 SV *layer = PerlIO_find_layer(name,len);
340 av_push(av,SvREFCNT_inc(layer));
353 PerlIO_define_layer(PerlIO_funcs *tab)
356 HV *stash = gv_stashpv("io::Layer", TRUE);
357 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
358 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
362 PerlIO_default_layer(I32 n)
367 PerlIO_funcs *tab = &PerlIO_stdio;
369 if (!PerlIO_layer_hv)
371 char *s = PerlEnv_getenv("PERLIO");
372 newXS("io::import",XS_io_import,__FILE__);
373 newXS("io::unimport",XS_io_unimport,__FILE__);
374 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
375 PerlIO_layer_hv = get_hv("io::layers",GV_ADD|GV_ADDMULTI);
376 PerlIO_layer_av = get_av("io::layers",GV_ADD|GV_ADDMULTI);
377 PerlIO_define_layer(&PerlIO_unix);
378 PerlIO_define_layer(&PerlIO_perlio);
379 PerlIO_define_layer(&PerlIO_stdio);
381 PerlIO_define_layer(&PerlIO_mmap);
383 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
388 while (*s && isSPACE((unsigned char)*s))
394 while (*e && !isSPACE((unsigned char)*e))
396 layer = PerlIO_find_layer(s,e-s);
399 PerlIO_debug("Pushing %.*s\n",(e-s),s);
400 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
403 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
409 len = av_len(PerlIO_layer_av);
412 if (PerlIO_stdio.Set_ptrcnt)
414 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
418 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
420 len = av_len(PerlIO_layer_av);
424 svp = av_fetch(PerlIO_layer_av,n,0);
425 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
427 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
429 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
433 #define PerlIO_default_top() PerlIO_default_layer(-1)
434 #define PerlIO_default_btm() PerlIO_default_layer(0)
442 PerlIO_fdopen(0,"Ir");
443 PerlIO_fdopen(1,"Iw");
444 PerlIO_fdopen(2,"Iw");
449 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
452 Newc('L',l,tab->size,char,PerlIOl);
455 Zero(l,tab->size,char);
459 if ((*l->tab->Pushed)(f,mode) != 0)
470 PerlIO_fdopen(int fd, const char *mode)
472 PerlIO_funcs *tab = PerlIO_default_top();
475 return (*tab->Fdopen)(tab,fd,mode);
480 PerlIO_open(const char *path, const char *mode)
482 PerlIO_funcs *tab = PerlIO_default_top();
485 return (*tab->Open)(tab,path,mode);
490 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
495 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
497 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
503 return PerlIO_open(path,mode);
508 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
510 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
515 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
517 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
522 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
524 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
529 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
531 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
536 PerlIO_tell(PerlIO *f)
538 return (*PerlIOBase(f)->tab->Tell)(f);
543 PerlIO_flush(PerlIO *f)
547 return (*PerlIOBase(f)->tab->Flush)(f);
551 PerlIO **table = &_perlio;
556 table = (PerlIO **)(f++);
557 for (i=1; i < PERLIO_TABLE_SIZE; i++)
559 if (*f && PerlIO_flush(f) != 0)
570 PerlIO_fill(PerlIO *f)
572 return (*PerlIOBase(f)->tab->Fill)(f);
577 PerlIO_isutf8(PerlIO *f)
579 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
584 PerlIO_eof(PerlIO *f)
586 return (*PerlIOBase(f)->tab->Eof)(f);
591 PerlIO_error(PerlIO *f)
593 return (*PerlIOBase(f)->tab->Error)(f);
596 #undef PerlIO_clearerr
598 PerlIO_clearerr(PerlIO *f)
600 (*PerlIOBase(f)->tab->Clearerr)(f);
603 #undef PerlIO_setlinebuf
605 PerlIO_setlinebuf(PerlIO *f)
607 (*PerlIOBase(f)->tab->Setlinebuf)(f);
610 #undef PerlIO_has_base
612 PerlIO_has_base(PerlIO *f)
616 return (PerlIOBase(f)->tab->Get_base != NULL);
621 #undef PerlIO_fast_gets
623 PerlIO_fast_gets(PerlIO *f)
627 PerlIOl *l = PerlIOBase(f);
628 return (l->tab->Set_ptrcnt != NULL);
633 #undef PerlIO_has_cntptr
635 PerlIO_has_cntptr(PerlIO *f)
639 PerlIO_funcs *tab = PerlIOBase(f)->tab;
640 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
645 #undef PerlIO_canset_cnt
647 PerlIO_canset_cnt(PerlIO *f)
651 PerlIOl *l = PerlIOBase(f);
652 return (l->tab->Set_ptrcnt != NULL);
657 #undef PerlIO_get_base
659 PerlIO_get_base(PerlIO *f)
661 return (*PerlIOBase(f)->tab->Get_base)(f);
664 #undef PerlIO_get_bufsiz
666 PerlIO_get_bufsiz(PerlIO *f)
668 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
671 #undef PerlIO_get_ptr
673 PerlIO_get_ptr(PerlIO *f)
675 return (*PerlIOBase(f)->tab->Get_ptr)(f);
678 #undef PerlIO_get_cnt
680 PerlIO_get_cnt(PerlIO *f)
682 return (*PerlIOBase(f)->tab->Get_cnt)(f);
685 #undef PerlIO_set_cnt
687 PerlIO_set_cnt(PerlIO *f,int cnt)
689 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
692 #undef PerlIO_set_ptrcnt
694 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
696 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
699 /*--------------------------------------------------------------------------------------*/
700 /* "Methods" of the "base class" */
703 PerlIOBase_fileno(PerlIO *f)
705 return PerlIO_fileno(PerlIONext(f));
709 PerlIOBase_pushed(PerlIO *f, const char *mode)
711 PerlIOl *l = PerlIOBase(f);
712 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
713 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
719 l->flags = PERLIO_F_CANREAD;
722 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
725 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
736 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
739 l->flags |= PERLIO_F_BINARY;
751 l->flags |= l->next->flags &
752 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
753 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
760 PerlIOBase_popped(PerlIO *f)
766 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
768 Off_t old = PerlIO_tell(f);
769 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
771 Off_t new = PerlIO_tell(f);
778 PerlIOBase_noop_ok(PerlIO *f)
784 PerlIOBase_noop_fail(PerlIO *f)
790 PerlIOBase_close(PerlIO *f)
793 if (PerlIO_flush(f) != 0)
795 if (PerlIO_close(PerlIONext(f)) != 0)
797 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
802 PerlIOBase_eof(PerlIO *f)
806 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
812 PerlIOBase_error(PerlIO *f)
816 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
822 PerlIOBase_clearerr(PerlIO *f)
826 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
831 PerlIOBase_setlinebuf(PerlIO *f)
836 /*--------------------------------------------------------------------------------------*/
837 /* Bottom-most level for UNIX-like case */
841 struct _PerlIO base; /* The generic part */
842 int fd; /* UNIX like file descriptor */
843 int oflags; /* open/fcntl flags */
847 PerlIOUnix_oflags(const char *mode)
862 oflags = O_CREAT|O_TRUNC;
873 oflags = O_CREAT|O_APPEND;
883 if (*mode || oflags == -1)
892 PerlIOUnix_fileno(PerlIO *f)
894 return PerlIOSelf(f,PerlIOUnix)->fd;
898 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
905 int oflags = PerlIOUnix_oflags(mode);
908 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
911 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
918 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
921 int oflags = PerlIOUnix_oflags(mode);
924 int fd = PerlLIO_open3(path,oflags,0666);
927 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
930 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
937 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
939 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
940 int oflags = PerlIOUnix_oflags(mode);
941 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
942 (*PerlIOBase(f)->tab->Close)(f);
945 int fd = PerlLIO_open3(path,oflags,0666);
950 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
958 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
960 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
961 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
965 SSize_t len = PerlLIO_read(fd,vbuf,count);
966 if (len >= 0 || errno != EINTR)
969 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
970 else if (len == 0 && count != 0)
971 PerlIOBase(f)->flags |= PERLIO_F_EOF;
978 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
980 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
983 SSize_t len = PerlLIO_write(fd,vbuf,count);
984 if (len >= 0 || errno != EINTR)
987 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
994 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
996 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
997 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
998 return (new == (Off_t) -1) ? -1 : 0;
1002 PerlIOUnix_tell(PerlIO *f)
1004 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1008 PerlIOUnix_close(PerlIO *f)
1010 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1012 while (PerlLIO_close(fd) != 0)
1022 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1027 PerlIO_funcs PerlIO_unix = {
1043 PerlIOBase_noop_ok, /* flush */
1044 PerlIOBase_noop_fail, /* fill */
1047 PerlIOBase_clearerr,
1048 PerlIOBase_setlinebuf,
1049 NULL, /* get_base */
1050 NULL, /* get_bufsiz */
1053 NULL, /* set_ptrcnt */
1056 /*--------------------------------------------------------------------------------------*/
1057 /* stdio as a layer */
1061 struct _PerlIO base;
1062 FILE * stdio; /* The stream */
1066 PerlIOStdio_fileno(PerlIO *f)
1068 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1073 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1101 stdio = fdopen(fd,mode);
1104 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1111 #undef PerlIO_importFILE
1113 PerlIO_importFILE(FILE *stdio, int fl)
1118 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1125 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1128 FILE *stdio = fopen(path,mode);
1131 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1138 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1140 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1141 FILE *stdio = freopen(path,mode,s->stdio);
1149 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1151 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1155 STDCHAR *buf = (STDCHAR *) vbuf;
1156 /* Perl is expecting PerlIO_getc() to fill the buffer
1157 * Linux's stdio does not do that for fread()
1167 got = fread(vbuf,1,count,s);
1172 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1174 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1175 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1179 int ch = *buf-- & 0xff;
1180 if (ungetc(ch,s) != ch)
1189 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1191 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1195 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1197 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1198 return fseek(stdio,offset,whence);
1202 PerlIOStdio_tell(PerlIO *f)
1204 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1205 return ftell(stdio);
1209 PerlIOStdio_close(PerlIO *f)
1211 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1215 PerlIOStdio_flush(PerlIO *f)
1217 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1218 return fflush(stdio);
1222 PerlIOStdio_fill(PerlIO *f)
1224 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1226 if (fflush(stdio) != 0)
1229 if (c == EOF || ungetc(c,stdio) != c)
1235 PerlIOStdio_eof(PerlIO *f)
1237 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1241 PerlIOStdio_error(PerlIO *f)
1243 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1247 PerlIOStdio_clearerr(PerlIO *f)
1249 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1253 PerlIOStdio_setlinebuf(PerlIO *f)
1255 #ifdef HAS_SETLINEBUF
1256 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1258 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1264 PerlIOStdio_get_base(PerlIO *f)
1266 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1267 return FILE_base(stdio);
1271 PerlIOStdio_get_bufsiz(PerlIO *f)
1273 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1274 return FILE_bufsiz(stdio);
1278 #ifdef USE_STDIO_PTR
1280 PerlIOStdio_get_ptr(PerlIO *f)
1282 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1283 return FILE_ptr(stdio);
1287 PerlIOStdio_get_cnt(PerlIO *f)
1289 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1290 return FILE_cnt(stdio);
1294 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1296 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1299 #ifdef STDIO_PTR_LVALUE
1300 FILE_ptr(stdio) = ptr;
1301 #ifdef STDIO_PTR_LVAL_SETS_CNT
1302 if (FILE_cnt(stdio) != (cnt))
1305 assert(FILE_cnt(stdio) == (cnt));
1308 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1309 /* Setting ptr _does_ change cnt - we are done */
1312 #else /* STDIO_PTR_LVALUE */
1314 #endif /* STDIO_PTR_LVALUE */
1316 /* Now (or only) set cnt */
1317 #ifdef STDIO_CNT_LVALUE
1318 FILE_cnt(stdio) = cnt;
1319 #else /* STDIO_CNT_LVALUE */
1320 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1321 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1322 #else /* STDIO_PTR_LVAL_SETS_CNT */
1324 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1325 #endif /* STDIO_CNT_LVALUE */
1330 PerlIO_funcs PerlIO_stdio = {
1332 sizeof(PerlIOStdio),
1350 PerlIOStdio_clearerr,
1351 PerlIOStdio_setlinebuf,
1353 PerlIOStdio_get_base,
1354 PerlIOStdio_get_bufsiz,
1359 #ifdef USE_STDIO_PTR
1360 PerlIOStdio_get_ptr,
1361 PerlIOStdio_get_cnt,
1362 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1363 PerlIOStdio_set_ptrcnt
1364 #else /* STDIO_PTR_LVALUE */
1366 #endif /* STDIO_PTR_LVALUE */
1367 #else /* USE_STDIO_PTR */
1371 #endif /* USE_STDIO_PTR */
1374 #undef PerlIO_exportFILE
1376 PerlIO_exportFILE(PerlIO *f, int fl)
1379 /* Should really push stdio discipline when we have them */
1380 return fdopen(PerlIO_fileno(f),"r+");
1383 #undef PerlIO_findFILE
1385 PerlIO_findFILE(PerlIO *f)
1387 return PerlIO_exportFILE(f,0);
1390 #undef PerlIO_releaseFILE
1392 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1396 /*--------------------------------------------------------------------------------------*/
1397 /* perlio buffer layer */
1400 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1402 PerlIO_funcs *tab = PerlIO_default_btm();
1410 f = (*tab->Fdopen)(tab,fd,mode);
1413 /* Initial stderr is unbuffered */
1414 if (!init || fd != 2)
1416 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1417 b->posn = PerlIO_tell(PerlIONext(f));
1424 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1426 PerlIO_funcs *tab = PerlIO_default_btm();
1427 PerlIO *f = (*tab->Open)(tab,path,mode);
1430 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1431 b->posn = PerlIO_tell(PerlIONext(f));
1437 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1439 PerlIO *next = PerlIONext(f);
1440 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1442 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1445 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1446 b->posn = PerlIO_tell(PerlIONext(f));
1451 /* This "flush" is akin to sfio's sync in that it handles files in either
1455 PerlIOBuf_flush(PerlIO *f)
1457 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1459 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1461 /* write() the buffer */
1462 STDCHAR *p = b->buf;
1466 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1473 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1478 b->posn += (p - b->buf);
1480 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1482 /* Note position change */
1483 b->posn += (b->ptr - b->buf);
1484 if (b->ptr < b->end)
1486 /* We did not consume all of it */
1487 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1489 b->posn = PerlIO_tell(PerlIONext(f));
1493 b->ptr = b->end = b->buf;
1494 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1495 if (PerlIO_flush(PerlIONext(f)) != 0)
1501 PerlIOBuf_fill(PerlIO *f)
1503 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1505 if (PerlIO_flush(f) != 0)
1507 b->ptr = b->end = b->buf;
1508 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1512 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1514 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1517 b->end = b->buf+avail;
1518 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1523 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1525 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1526 STDCHAR *buf = (STDCHAR *) vbuf;
1532 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1536 SSize_t avail = (b->end - b->ptr);
1537 if ((SSize_t) count < avail)
1541 Copy(b->ptr,buf,avail,char);
1547 if (count && (b->ptr >= b->end))
1549 if (PerlIO_fill(f) != 0)
1559 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1561 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1562 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1565 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1571 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1573 avail = (b->ptr - b->buf);
1574 if (avail > (SSize_t) count)
1581 if (avail > (SSize_t) count)
1583 b->end = b->ptr + avail;
1590 Copy(buf,b->ptr,avail,char);
1594 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1601 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1603 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1604 const STDCHAR *buf = (const STDCHAR *) vbuf;
1608 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1612 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1613 if ((SSize_t) count < avail)
1615 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1616 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1636 Copy(buf,b->ptr,avail,char);
1643 if (b->ptr >= (b->buf + b->bufsiz))
1650 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1652 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1653 int code = PerlIO_flush(f);
1656 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1657 code = PerlIO_seek(PerlIONext(f),offset,whence);
1660 b->posn = PerlIO_tell(PerlIONext(f));
1667 PerlIOBuf_tell(PerlIO *f)
1669 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1670 Off_t posn = b->posn;
1672 posn += (b->ptr - b->buf);
1677 PerlIOBuf_close(PerlIO *f)
1679 IV code = PerlIOBase_close(f);
1680 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1681 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1686 b->ptr = b->end = b->buf;
1687 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1692 PerlIOBuf_setlinebuf(PerlIO *f)
1696 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1701 PerlIOBuf_get_ptr(PerlIO *f)
1703 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1710 PerlIOBuf_get_cnt(PerlIO *f)
1712 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1715 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1716 return (b->end - b->ptr);
1721 PerlIOBuf_get_base(PerlIO *f)
1723 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1728 New('B',b->buf,b->bufsiz,STDCHAR);
1731 b->buf = (STDCHAR *)&b->oneword;
1732 b->bufsiz = sizeof(b->oneword);
1741 PerlIOBuf_bufsiz(PerlIO *f)
1743 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1746 return (b->end - b->buf);
1750 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1752 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1756 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1759 assert(PerlIO_get_cnt(f) == cnt);
1760 assert(b->ptr >= b->buf);
1762 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1765 PerlIO_funcs PerlIO_perlio = {
1785 PerlIOBase_clearerr,
1786 PerlIOBuf_setlinebuf,
1791 PerlIOBuf_set_ptrcnt,
1795 /*--------------------------------------------------------------------------------------*/
1796 /* mmap as "buffer" layer */
1800 PerlIOBuf base; /* PerlIOBuf stuff */
1801 Mmap_t mptr; /* Mapped address */
1802 Size_t len; /* mapped length */
1803 STDCHAR *bbuf; /* malloced buffer if map fails */
1807 static size_t page_size = 0;
1810 PerlIOMmap_map(PerlIO *f)
1813 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1814 PerlIOBuf *b = &m->base;
1815 IV flags = PerlIOBase(f)->flags;
1819 if (flags & PERLIO_F_CANREAD)
1821 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1822 int fd = PerlIO_fileno(f);
1824 code = fstat(fd,&st);
1825 if (code == 0 && S_ISREG(st.st_mode))
1827 SSize_t len = st.st_size - b->posn;
1832 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1834 SETERRNO(0,SS$_NORMAL);
1835 # ifdef _SC_PAGESIZE
1836 page_size = sysconf(_SC_PAGESIZE);
1838 page_size = sysconf(_SC_PAGE_SIZE);
1840 if ((long)page_size < 0) {
1845 (void)SvUPGRADE(error, SVt_PV);
1846 msg = SvPVx(error, n_a);
1847 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1850 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1854 # ifdef HAS_GETPAGESIZE
1855 page_size = getpagesize();
1857 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
1858 page_size = PAGESIZE; /* compiletime, bad */
1862 if ((IV)page_size <= 0)
1863 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1867 /* This is a hack - should never happen - open should have set it ! */
1868 b->posn = PerlIO_tell(PerlIONext(f));
1870 posn = (b->posn / page_size) * page_size;
1871 len = st.st_size - posn;
1872 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1873 if (m->mptr && m->mptr != (Mmap_t) -1)
1875 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1876 madvise(m->mptr, len, MADV_SEQUENTIAL);
1878 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1879 b->end = ((STDCHAR *)m->mptr) + len;
1880 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
1891 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1893 b->ptr = b->end = b->ptr;
1902 PerlIOMmap_unmap(PerlIO *f)
1904 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1905 PerlIOBuf *b = &m->base;
1911 code = munmap(m->mptr, m->len);
1915 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1918 b->ptr = b->end = b->buf;
1919 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1925 PerlIOMmap_get_base(PerlIO *f)
1927 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1928 PerlIOBuf *b = &m->base;
1929 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1931 /* Already have a readbuffer in progress */
1936 /* We have a write buffer or flushed PerlIOBuf read buffer */
1937 m->bbuf = b->buf; /* save it in case we need it again */
1938 b->buf = NULL; /* Clear to trigger below */
1942 PerlIOMmap_map(f); /* Try and map it */
1945 /* Map did not work - recover PerlIOBuf buffer if we have one */
1949 b->ptr = b->end = b->buf;
1952 return PerlIOBuf_get_base(f);
1956 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
1958 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1959 PerlIOBuf *b = &m->base;
1960 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1962 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
1965 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1970 /* Loose the unwritable mapped buffer */
1972 /* If flush took the "buffer" see if we have one from before */
1973 if (!b->buf && m->bbuf)
1977 PerlIOBuf_get_base(f);
1981 return PerlIOBuf_unread(f,vbuf,count);
1985 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
1987 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1988 PerlIOBuf *b = &m->base;
1989 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
1991 /* No, or wrong sort of, buffer */
1994 if (PerlIOMmap_unmap(f) != 0)
1997 /* If unmap took the "buffer" see if we have one from before */
1998 if (!b->buf && m->bbuf)
2002 PerlIOBuf_get_base(f);
2006 return PerlIOBuf_write(f,vbuf,count);
2010 PerlIOMmap_flush(PerlIO *f)
2012 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2013 PerlIOBuf *b = &m->base;
2014 IV code = PerlIOBuf_flush(f);
2015 /* Now we are "synced" at PerlIOBuf level */
2020 /* Unmap the buffer */
2021 if (PerlIOMmap_unmap(f) != 0)
2026 /* We seem to have a PerlIOBuf buffer which was not mapped
2027 * remember it in case we need one later
2036 PerlIOMmap_fill(PerlIO *f)
2038 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2039 IV code = PerlIO_flush(f);
2040 if (code == 0 && !b->buf)
2042 code = PerlIOMmap_map(f);
2044 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2046 code = PerlIOBuf_fill(f);
2052 PerlIOMmap_close(PerlIO *f)
2054 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2055 PerlIOBuf *b = &m->base;
2056 IV code = PerlIO_flush(f);
2061 b->ptr = b->end = b->buf;
2063 if (PerlIOBuf_close(f) != 0)
2069 PerlIO_funcs PerlIO_mmap = {
2089 PerlIOBase_clearerr,
2090 PerlIOBuf_setlinebuf,
2091 PerlIOMmap_get_base,
2095 PerlIOBuf_set_ptrcnt,
2098 #endif /* HAS_MMAP */
2105 atexit(&PerlIO_cleanup);
2114 PerlIO_stdstreams();
2118 #undef PerlIO_stdout
2123 PerlIO_stdstreams();
2127 #undef PerlIO_stderr
2132 PerlIO_stdstreams();
2136 /*--------------------------------------------------------------------------------------*/
2138 #undef PerlIO_getname
2140 PerlIO_getname(PerlIO *f, char *buf)
2143 Perl_croak(aTHX_ "Don't know how to get file name");
2148 /*--------------------------------------------------------------------------------------*/
2149 /* Functions which can be called on any kind of PerlIO implemented
2155 PerlIO_getc(PerlIO *f)
2158 SSize_t count = PerlIO_read(f,buf,1);
2161 return (unsigned char) buf[0];
2166 #undef PerlIO_ungetc
2168 PerlIO_ungetc(PerlIO *f, int ch)
2173 if (PerlIO_unread(f,&buf,1) == 1)
2181 PerlIO_putc(PerlIO *f, int ch)
2184 return PerlIO_write(f,&buf,1);
2189 PerlIO_puts(PerlIO *f, const char *s)
2191 STRLEN len = strlen(s);
2192 return PerlIO_write(f,s,len);
2195 #undef PerlIO_rewind
2197 PerlIO_rewind(PerlIO *f)
2199 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2203 #undef PerlIO_vprintf
2205 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2208 SV *sv = newSVpvn("",0);
2211 sv_vcatpvf(sv, fmt, &ap);
2213 return PerlIO_write(f,s,len);
2216 #undef PerlIO_printf
2218 PerlIO_printf(PerlIO *f,const char *fmt,...)
2223 result = PerlIO_vprintf(f,fmt,ap);
2228 #undef PerlIO_stdoutf
2230 PerlIO_stdoutf(const char *fmt,...)
2235 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2240 #undef PerlIO_tmpfile
2242 PerlIO_tmpfile(void)
2245 /* I have no idea how portable mkstemp() is ... */
2246 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2247 int fd = mkstemp(SvPVX(sv));
2251 f = PerlIO_fdopen(fd,"w+");
2254 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2256 PerlLIO_unlink(SvPVX(sv));
2265 #endif /* USE_SFIO */
2266 #endif /* PERLIO_IS_STDIO */
2268 /*======================================================================================*/
2269 /* Now some functions in terms of above which may be needed even if
2270 we are not in true PerlIO mode
2274 #undef PerlIO_setpos
2276 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2278 return PerlIO_seek(f,*pos,0);
2281 #ifndef PERLIO_IS_STDIO
2282 #undef PerlIO_setpos
2284 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2286 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2287 return fsetpos64(f, pos);
2289 return fsetpos(f, pos);
2296 #undef PerlIO_getpos
2298 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2300 *pos = PerlIO_tell(f);
2301 return *pos == -1 ? -1 : 0;
2304 #ifndef PERLIO_IS_STDIO
2305 #undef PerlIO_getpos
2307 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2309 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2310 return fgetpos64(f, pos);
2312 return fgetpos(f, pos);
2318 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2321 vprintf(char *pat, char *args)
2323 _doprnt(pat, args, stdout);
2324 return 0; /* wrong, but perl doesn't use the return value */
2328 vfprintf(FILE *fd, char *pat, char *args)
2330 _doprnt(pat, args, fd);
2331 return 0; /* wrong, but perl doesn't use the return value */
2336 #ifndef PerlIO_vsprintf
2338 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2340 int val = vsprintf(s, fmt, ap);
2343 if (strlen(s) >= (STRLEN)n)
2346 (void)PerlIO_puts(Perl_error_log,
2347 "panic: sprintf overflow - memory corrupted!\n");
2355 #ifndef PerlIO_sprintf
2357 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2362 result = PerlIO_vsprintf(s, n, fmt, ap);
2368 #endif /* !PERL_IMPLICIT_SYS */