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
33 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
35 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
39 #if !defined(PERL_IMPLICIT_SYS)
41 #ifdef PERLIO_IS_STDIO
46 /* Does nothing (yet) except force this file to be included
47 in perl binary. That allows this file to force inclusion
48 of other functions that may be required by loadable
49 extensions e.g. for FileHandle::tmpfile
60 #else /* PERLIO_IS_STDIO */
67 /* This section is just to make sure these functions
68 get pulled in from libsfio.a
81 /* Force this file to be included in perl binary. Which allows
82 * this file to force inclusion of other functions that may be
83 * required by loadable extensions e.g. for FileHandle::tmpfile
87 * sfio does its own 'autoflush' on stdout in common cases.
88 * Flush results in a lot of lseek()s to regular files and
89 * lot of small writes to pipes.
91 sfset(sfstdout,SF_SHARE,0);
95 /*======================================================================================*/
96 /* Implement all the PerlIO interface ourselves.
101 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
106 #include <sys/mman.h>
111 void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2)));
114 PerlIO_debug(char *fmt,...)
119 char *s = PerlEnv_getenv("PERLIO_DEBUG");
121 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
129 SV *sv = newSVpvn("",0);
133 s = CopFILE(PL_curcop);
136 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
137 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
140 PerlLIO_write(dbg,s,len);
146 /*--------------------------------------------------------------------------------------*/
148 /* Inner level routines */
150 /* Table of pointers to the PerlIO structs (malloc'ed) */
151 PerlIO *_perlio = NULL;
152 #define PERLIO_TABLE_SIZE 64
155 PerlIO_allocate(void)
157 /* Find a free slot in the table, allocating new table as necessary */
158 PerlIO **last = &_perlio;
163 last = (PerlIO **)(f);
164 for (i=1; i < PERLIO_TABLE_SIZE; i++)
172 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
180 PerlIO_cleantable(PerlIO **tablep)
182 PerlIO *table = *tablep;
186 PerlIO_cleantable((PerlIO **) &(table[0]));
187 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
204 PerlIO_cleantable(&_perlio);
208 PerlIO_pop(PerlIO *f)
213 (*l->tab->Popped)(f);
219 /*--------------------------------------------------------------------------------------*/
220 /* XS Interface for perl code */
226 char *s = GvNAME(gv);
227 STRLEN l = GvNAMELEN(gv);
228 PerlIO_debug("%.*s\n",(int) l,s);
232 XS(XS_perlio_unimport)
236 char *s = GvNAME(gv);
237 STRLEN l = GvNAMELEN(gv);
238 PerlIO_debug("%.*s\n",(int) l,s);
243 PerlIO_find_layer(const char *name, STRLEN len)
250 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
251 if (svp && (sv = *svp) && SvROK(sv))
258 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
262 IO *io = GvIOn((GV *)SvRV(sv));
263 PerlIO *ifp = IoIFP(io);
264 PerlIO *ofp = IoOFP(io);
265 AV *av = (AV *) mg->mg_obj;
266 Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
272 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
276 IO *io = GvIOn((GV *)SvRV(sv));
277 PerlIO *ifp = IoIFP(io);
278 PerlIO *ofp = IoOFP(io);
279 AV *av = (AV *) mg->mg_obj;
280 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
286 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
288 Perl_warn(aTHX_ "clear %_",sv);
293 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
295 Perl_warn(aTHX_ "free %_",sv);
299 MGVTBL perlio_vtab = {
307 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
310 SV *sv = SvRV(ST(1));
315 sv_magic(sv, (SV *)av, '~', NULL, 0);
317 mg = mg_find(sv,'~');
318 mg->mg_virtual = &perlio_vtab;
320 Perl_warn(aTHX_ "attrib %_",sv);
321 for (i=2; i < items; i++)
324 const char *name = SvPV(ST(i),len);
325 SV *layer = PerlIO_find_layer(name,len);
328 av_push(av,SvREFCNT_inc(layer));
341 PerlIO_define_layer(PerlIO_funcs *tab)
344 HV *stash = gv_stashpv("perlio::Layer", TRUE);
345 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
346 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
350 PerlIO_default_layer(I32 n)
355 PerlIO_funcs *tab = &PerlIO_stdio;
357 if (!PerlIO_layer_hv)
359 const char *s = PerlEnv_getenv("PERLIO");
360 newXS("perlio::import",XS_perlio_import,__FILE__);
361 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
363 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
365 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
366 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
367 PerlIO_define_layer(&PerlIO_unix);
368 PerlIO_define_layer(&PerlIO_perlio);
369 PerlIO_define_layer(&PerlIO_stdio);
371 PerlIO_define_layer(&PerlIO_mmap);
373 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
378 while (*s && isSPACE((unsigned char)*s))
384 while (*e && !isSPACE((unsigned char)*e))
388 layer = PerlIO_find_layer(s,e-s);
391 PerlIO_debug("Pushing %.*s\n",(e-s),s);
392 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
395 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
401 len = av_len(PerlIO_layer_av);
404 if (PerlIO_stdio.Set_ptrcnt)
406 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
410 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
412 len = av_len(PerlIO_layer_av);
416 svp = av_fetch(PerlIO_layer_av,n,0);
417 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
419 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
421 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
426 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
430 const char *s = names;
440 while (*e && *e != ':' && !isSPACE(*e))
444 SV *layer = PerlIO_find_layer(s,e-s);
447 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
450 PerlIO *new = PerlIO_push(f,tab,mode);
456 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
465 #define PerlIO_default_top() PerlIO_default_layer(-1)
466 #define PerlIO_default_btm() PerlIO_default_layer(0)
474 PerlIO_fdopen(0,"Ir");
475 PerlIO_fdopen(1,"Iw");
476 PerlIO_fdopen(2,"Iw");
481 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
484 Newc('L',l,tab->size,char,PerlIOl);
487 Zero(l,tab->size,char);
491 if ((*l->tab->Pushed)(f,mode) != 0)
500 /*--------------------------------------------------------------------------------------*/
501 /* Given the abstraction above the public API functions */
505 PerlIO_close(PerlIO *f)
507 int code = (*PerlIOBase(f)->tab->Close)(f);
517 PerlIO_fileno(PerlIO *f)
519 return (*PerlIOBase(f)->tab->Fileno)(f);
526 PerlIO_fdopen(int fd, const char *mode)
528 PerlIO_funcs *tab = PerlIO_default_top();
531 return (*tab->Fdopen)(tab,fd,mode);
536 PerlIO_open(const char *path, const char *mode)
538 PerlIO_funcs *tab = PerlIO_default_top();
541 return (*tab->Open)(tab,path,mode);
546 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
551 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
553 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
559 return PerlIO_open(path,mode);
564 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
566 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
571 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
573 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
578 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
580 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
585 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
587 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
592 PerlIO_tell(PerlIO *f)
594 return (*PerlIOBase(f)->tab->Tell)(f);
599 PerlIO_flush(PerlIO *f)
603 return (*PerlIOBase(f)->tab->Flush)(f);
607 PerlIO **table = &_perlio;
612 table = (PerlIO **)(f++);
613 for (i=1; i < PERLIO_TABLE_SIZE; i++)
615 if (*f && PerlIO_flush(f) != 0)
626 PerlIO_fill(PerlIO *f)
628 return (*PerlIOBase(f)->tab->Fill)(f);
633 PerlIO_isutf8(PerlIO *f)
635 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
640 PerlIO_eof(PerlIO *f)
642 return (*PerlIOBase(f)->tab->Eof)(f);
647 PerlIO_error(PerlIO *f)
649 return (*PerlIOBase(f)->tab->Error)(f);
652 #undef PerlIO_clearerr
654 PerlIO_clearerr(PerlIO *f)
656 (*PerlIOBase(f)->tab->Clearerr)(f);
659 #undef PerlIO_setlinebuf
661 PerlIO_setlinebuf(PerlIO *f)
663 (*PerlIOBase(f)->tab->Setlinebuf)(f);
666 #undef PerlIO_has_base
668 PerlIO_has_base(PerlIO *f)
672 return (PerlIOBase(f)->tab->Get_base != NULL);
677 #undef PerlIO_fast_gets
679 PerlIO_fast_gets(PerlIO *f)
683 PerlIOl *l = PerlIOBase(f);
684 return (l->tab->Set_ptrcnt != NULL);
689 #undef PerlIO_has_cntptr
691 PerlIO_has_cntptr(PerlIO *f)
695 PerlIO_funcs *tab = PerlIOBase(f)->tab;
696 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
701 #undef PerlIO_canset_cnt
703 PerlIO_canset_cnt(PerlIO *f)
707 PerlIOl *l = PerlIOBase(f);
708 return (l->tab->Set_ptrcnt != NULL);
713 #undef PerlIO_get_base
715 PerlIO_get_base(PerlIO *f)
717 return (*PerlIOBase(f)->tab->Get_base)(f);
720 #undef PerlIO_get_bufsiz
722 PerlIO_get_bufsiz(PerlIO *f)
724 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
727 #undef PerlIO_get_ptr
729 PerlIO_get_ptr(PerlIO *f)
731 return (*PerlIOBase(f)->tab->Get_ptr)(f);
734 #undef PerlIO_get_cnt
736 PerlIO_get_cnt(PerlIO *f)
738 return (*PerlIOBase(f)->tab->Get_cnt)(f);
741 #undef PerlIO_set_cnt
743 PerlIO_set_cnt(PerlIO *f,int cnt)
745 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
748 #undef PerlIO_set_ptrcnt
750 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
752 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
755 /*--------------------------------------------------------------------------------------*/
756 /* "Methods" of the "base class" */
759 PerlIOBase_fileno(PerlIO *f)
761 return PerlIO_fileno(PerlIONext(f));
765 PerlIOBase_pushed(PerlIO *f, const char *mode)
767 PerlIOl *l = PerlIOBase(f);
768 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
769 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
775 l->flags = PERLIO_F_CANREAD;
778 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
781 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
792 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
795 l->flags |= PERLIO_F_BINARY;
807 l->flags |= l->next->flags &
808 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
809 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
816 PerlIOBase_popped(PerlIO *f)
822 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
824 Off_t old = PerlIO_tell(f);
825 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
827 Off_t new = PerlIO_tell(f);
834 PerlIOBase_noop_ok(PerlIO *f)
840 PerlIOBase_noop_fail(PerlIO *f)
846 PerlIOBase_close(PerlIO *f)
849 if (PerlIO_flush(f) != 0)
851 if (PerlIO_close(PerlIONext(f)) != 0)
853 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
858 PerlIOBase_eof(PerlIO *f)
862 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
868 PerlIOBase_error(PerlIO *f)
872 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
878 PerlIOBase_clearerr(PerlIO *f)
882 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
887 PerlIOBase_setlinebuf(PerlIO *f)
892 /*--------------------------------------------------------------------------------------*/
893 /* Bottom-most level for UNIX-like case */
897 struct _PerlIO base; /* The generic part */
898 int fd; /* UNIX like file descriptor */
899 int oflags; /* open/fcntl flags */
903 PerlIOUnix_oflags(const char *mode)
918 oflags = O_CREAT|O_TRUNC;
929 oflags = O_CREAT|O_APPEND;
939 if (*mode || oflags == -1)
948 PerlIOUnix_fileno(PerlIO *f)
950 return PerlIOSelf(f,PerlIOUnix)->fd;
954 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
961 int oflags = PerlIOUnix_oflags(mode);
964 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
967 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
974 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
977 int oflags = PerlIOUnix_oflags(mode);
980 int fd = PerlLIO_open3(path,oflags,0666);
983 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
986 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
993 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
995 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
996 int oflags = PerlIOUnix_oflags(mode);
997 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
998 (*PerlIOBase(f)->tab->Close)(f);
1001 int fd = PerlLIO_open3(path,oflags,0666);
1006 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1014 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1016 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1017 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1021 SSize_t len = PerlLIO_read(fd,vbuf,count);
1022 if (len >= 0 || errno != EINTR)
1025 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1026 else if (len == 0 && count != 0)
1027 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1034 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1036 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1039 SSize_t len = PerlLIO_write(fd,vbuf,count);
1040 if (len >= 0 || errno != EINTR)
1043 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1050 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1052 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1053 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1054 return (new == (Off_t) -1) ? -1 : 0;
1058 PerlIOUnix_tell(PerlIO *f)
1060 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1064 PerlIOUnix_close(PerlIO *f)
1066 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1068 while (PerlLIO_close(fd) != 0)
1078 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1083 PerlIO_funcs PerlIO_unix = {
1099 PerlIOBase_noop_ok, /* flush */
1100 PerlIOBase_noop_fail, /* fill */
1103 PerlIOBase_clearerr,
1104 PerlIOBase_setlinebuf,
1105 NULL, /* get_base */
1106 NULL, /* get_bufsiz */
1109 NULL, /* set_ptrcnt */
1112 /*--------------------------------------------------------------------------------------*/
1113 /* stdio as a layer */
1117 struct _PerlIO base;
1118 FILE * stdio; /* The stream */
1122 PerlIOStdio_fileno(PerlIO *f)
1124 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1129 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1157 stdio = fdopen(fd,mode);
1160 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1167 #undef PerlIO_importFILE
1169 PerlIO_importFILE(FILE *stdio, int fl)
1174 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1181 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1184 FILE *stdio = fopen(path,mode);
1187 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1194 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1196 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1197 FILE *stdio = freopen(path,mode,s->stdio);
1205 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1207 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1211 STDCHAR *buf = (STDCHAR *) vbuf;
1212 /* Perl is expecting PerlIO_getc() to fill the buffer
1213 * Linux's stdio does not do that for fread()
1223 got = fread(vbuf,1,count,s);
1228 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1230 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1231 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1235 int ch = *buf-- & 0xff;
1236 if (ungetc(ch,s) != ch)
1245 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1247 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1251 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1253 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1254 return fseek(stdio,offset,whence);
1258 PerlIOStdio_tell(PerlIO *f)
1260 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1261 return ftell(stdio);
1265 PerlIOStdio_close(PerlIO *f)
1267 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1271 PerlIOStdio_flush(PerlIO *f)
1273 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1274 return fflush(stdio);
1278 PerlIOStdio_fill(PerlIO *f)
1280 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1282 if (fflush(stdio) != 0)
1285 if (c == EOF || ungetc(c,stdio) != c)
1291 PerlIOStdio_eof(PerlIO *f)
1293 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1297 PerlIOStdio_error(PerlIO *f)
1299 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1303 PerlIOStdio_clearerr(PerlIO *f)
1305 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1309 PerlIOStdio_setlinebuf(PerlIO *f)
1311 #ifdef HAS_SETLINEBUF
1312 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1314 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1320 PerlIOStdio_get_base(PerlIO *f)
1322 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1323 return FILE_base(stdio);
1327 PerlIOStdio_get_bufsiz(PerlIO *f)
1329 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1330 return FILE_bufsiz(stdio);
1334 #ifdef USE_STDIO_PTR
1336 PerlIOStdio_get_ptr(PerlIO *f)
1338 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1339 return FILE_ptr(stdio);
1343 PerlIOStdio_get_cnt(PerlIO *f)
1345 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1346 return FILE_cnt(stdio);
1350 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1352 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1355 #ifdef STDIO_PTR_LVALUE
1356 FILE_ptr(stdio) = ptr;
1357 #ifdef STDIO_PTR_LVAL_SETS_CNT
1358 if (FILE_cnt(stdio) != (cnt))
1361 assert(FILE_cnt(stdio) == (cnt));
1364 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1365 /* Setting ptr _does_ change cnt - we are done */
1368 #else /* STDIO_PTR_LVALUE */
1370 #endif /* STDIO_PTR_LVALUE */
1372 /* Now (or only) set cnt */
1373 #ifdef STDIO_CNT_LVALUE
1374 FILE_cnt(stdio) = cnt;
1375 #else /* STDIO_CNT_LVALUE */
1376 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1377 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1378 #else /* STDIO_PTR_LVAL_SETS_CNT */
1380 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1381 #endif /* STDIO_CNT_LVALUE */
1386 PerlIO_funcs PerlIO_stdio = {
1388 sizeof(PerlIOStdio),
1406 PerlIOStdio_clearerr,
1407 PerlIOStdio_setlinebuf,
1409 PerlIOStdio_get_base,
1410 PerlIOStdio_get_bufsiz,
1415 #ifdef USE_STDIO_PTR
1416 PerlIOStdio_get_ptr,
1417 PerlIOStdio_get_cnt,
1418 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1419 PerlIOStdio_set_ptrcnt
1420 #else /* STDIO_PTR_LVALUE */
1422 #endif /* STDIO_PTR_LVALUE */
1423 #else /* USE_STDIO_PTR */
1427 #endif /* USE_STDIO_PTR */
1430 #undef PerlIO_exportFILE
1432 PerlIO_exportFILE(PerlIO *f, int fl)
1435 /* Should really push stdio discipline when we have them */
1436 return fdopen(PerlIO_fileno(f),"r+");
1439 #undef PerlIO_findFILE
1441 PerlIO_findFILE(PerlIO *f)
1443 return PerlIO_exportFILE(f,0);
1446 #undef PerlIO_releaseFILE
1448 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1452 /*--------------------------------------------------------------------------------------*/
1453 /* perlio buffer layer */
1456 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1458 PerlIO_funcs *tab = PerlIO_default_btm();
1466 f = (*tab->Fdopen)(tab,fd,mode);
1469 /* Initial stderr is unbuffered */
1470 if (!init || fd != 2)
1472 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1473 b->posn = PerlIO_tell(PerlIONext(f));
1480 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1482 PerlIO_funcs *tab = PerlIO_default_btm();
1483 PerlIO *f = (*tab->Open)(tab,path,mode);
1486 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1487 b->posn = PerlIO_tell(PerlIONext(f));
1493 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1495 PerlIO *next = PerlIONext(f);
1496 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1498 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1501 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1502 b->posn = PerlIO_tell(PerlIONext(f));
1507 /* This "flush" is akin to sfio's sync in that it handles files in either
1511 PerlIOBuf_flush(PerlIO *f)
1513 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1515 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1517 /* write() the buffer */
1518 STDCHAR *p = b->buf;
1522 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1529 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1534 b->posn += (p - b->buf);
1536 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1538 /* Note position change */
1539 b->posn += (b->ptr - b->buf);
1540 if (b->ptr < b->end)
1542 /* We did not consume all of it */
1543 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1545 b->posn = PerlIO_tell(PerlIONext(f));
1549 b->ptr = b->end = b->buf;
1550 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1551 if (PerlIO_flush(PerlIONext(f)) != 0)
1557 PerlIOBuf_fill(PerlIO *f)
1559 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1561 if (PerlIO_flush(f) != 0)
1563 b->ptr = b->end = b->buf;
1564 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1568 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1570 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1573 b->end = b->buf+avail;
1574 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1579 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1581 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1582 STDCHAR *buf = (STDCHAR *) vbuf;
1588 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1592 SSize_t avail = (b->end - b->ptr);
1593 if ((SSize_t) count < avail)
1597 Copy(b->ptr,buf,avail,char);
1603 if (count && (b->ptr >= b->end))
1605 if (PerlIO_fill(f) != 0)
1615 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1617 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1618 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1621 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1627 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1629 avail = (b->ptr - b->buf);
1630 if (avail > (SSize_t) count)
1637 if (avail > (SSize_t) count)
1639 b->end = b->ptr + avail;
1646 Copy(buf,b->ptr,avail,char);
1650 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1657 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1659 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1660 const STDCHAR *buf = (const STDCHAR *) vbuf;
1664 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1668 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1669 if ((SSize_t) count < avail)
1671 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1672 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1692 Copy(buf,b->ptr,avail,char);
1699 if (b->ptr >= (b->buf + b->bufsiz))
1706 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1708 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1709 int code = PerlIO_flush(f);
1712 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1713 code = PerlIO_seek(PerlIONext(f),offset,whence);
1716 b->posn = PerlIO_tell(PerlIONext(f));
1723 PerlIOBuf_tell(PerlIO *f)
1725 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1726 Off_t posn = b->posn;
1728 posn += (b->ptr - b->buf);
1733 PerlIOBuf_close(PerlIO *f)
1735 IV code = PerlIOBase_close(f);
1736 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1737 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1742 b->ptr = b->end = b->buf;
1743 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1748 PerlIOBuf_setlinebuf(PerlIO *f)
1752 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1757 PerlIOBuf_get_ptr(PerlIO *f)
1759 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1766 PerlIOBuf_get_cnt(PerlIO *f)
1768 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1771 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1772 return (b->end - b->ptr);
1777 PerlIOBuf_get_base(PerlIO *f)
1779 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1784 New('B',b->buf,b->bufsiz,STDCHAR);
1787 b->buf = (STDCHAR *)&b->oneword;
1788 b->bufsiz = sizeof(b->oneword);
1797 PerlIOBuf_bufsiz(PerlIO *f)
1799 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1802 return (b->end - b->buf);
1806 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1808 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1812 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1815 assert(PerlIO_get_cnt(f) == cnt);
1816 assert(b->ptr >= b->buf);
1818 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1821 PerlIO_funcs PerlIO_perlio = {
1841 PerlIOBase_clearerr,
1842 PerlIOBuf_setlinebuf,
1847 PerlIOBuf_set_ptrcnt,
1851 /*--------------------------------------------------------------------------------------*/
1852 /* mmap as "buffer" layer */
1856 PerlIOBuf base; /* PerlIOBuf stuff */
1857 Mmap_t mptr; /* Mapped address */
1858 Size_t len; /* mapped length */
1859 STDCHAR *bbuf; /* malloced buffer if map fails */
1863 static size_t page_size = 0;
1866 PerlIOMmap_map(PerlIO *f)
1869 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1870 PerlIOBuf *b = &m->base;
1871 IV flags = PerlIOBase(f)->flags;
1875 if (flags & PERLIO_F_CANREAD)
1877 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1878 int fd = PerlIO_fileno(f);
1880 code = fstat(fd,&st);
1881 if (code == 0 && S_ISREG(st.st_mode))
1883 SSize_t len = st.st_size - b->posn;
1888 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1890 SETERRNO(0,SS$_NORMAL);
1891 # ifdef _SC_PAGESIZE
1892 page_size = sysconf(_SC_PAGESIZE);
1894 page_size = sysconf(_SC_PAGE_SIZE);
1896 if ((long)page_size < 0) {
1901 (void)SvUPGRADE(error, SVt_PV);
1902 msg = SvPVx(error, n_a);
1903 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1906 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1910 # ifdef HAS_GETPAGESIZE
1911 page_size = getpagesize();
1913 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
1914 page_size = PAGESIZE; /* compiletime, bad */
1918 if ((IV)page_size <= 0)
1919 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1923 /* This is a hack - should never happen - open should have set it ! */
1924 b->posn = PerlIO_tell(PerlIONext(f));
1926 posn = (b->posn / page_size) * page_size;
1927 len = st.st_size - posn;
1928 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1929 if (m->mptr && m->mptr != (Mmap_t) -1)
1931 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1932 madvise(m->mptr, len, MADV_SEQUENTIAL);
1934 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1935 b->end = ((STDCHAR *)m->mptr) + len;
1936 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
1947 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1949 b->ptr = b->end = b->ptr;
1958 PerlIOMmap_unmap(PerlIO *f)
1960 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1961 PerlIOBuf *b = &m->base;
1967 code = munmap(m->mptr, m->len);
1971 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1974 b->ptr = b->end = b->buf;
1975 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1981 PerlIOMmap_get_base(PerlIO *f)
1983 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1984 PerlIOBuf *b = &m->base;
1985 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1987 /* Already have a readbuffer in progress */
1992 /* We have a write buffer or flushed PerlIOBuf read buffer */
1993 m->bbuf = b->buf; /* save it in case we need it again */
1994 b->buf = NULL; /* Clear to trigger below */
1998 PerlIOMmap_map(f); /* Try and map it */
2001 /* Map did not work - recover PerlIOBuf buffer if we have one */
2005 b->ptr = b->end = b->buf;
2008 return PerlIOBuf_get_base(f);
2012 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2014 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2015 PerlIOBuf *b = &m->base;
2016 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2018 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2021 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2026 /* Loose the unwritable mapped buffer */
2028 /* If flush took the "buffer" see if we have one from before */
2029 if (!b->buf && m->bbuf)
2033 PerlIOBuf_get_base(f);
2037 return PerlIOBuf_unread(f,vbuf,count);
2041 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2043 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2044 PerlIOBuf *b = &m->base;
2045 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2047 /* No, or wrong sort of, buffer */
2050 if (PerlIOMmap_unmap(f) != 0)
2053 /* If unmap took the "buffer" see if we have one from before */
2054 if (!b->buf && m->bbuf)
2058 PerlIOBuf_get_base(f);
2062 return PerlIOBuf_write(f,vbuf,count);
2066 PerlIOMmap_flush(PerlIO *f)
2068 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2069 PerlIOBuf *b = &m->base;
2070 IV code = PerlIOBuf_flush(f);
2071 /* Now we are "synced" at PerlIOBuf level */
2076 /* Unmap the buffer */
2077 if (PerlIOMmap_unmap(f) != 0)
2082 /* We seem to have a PerlIOBuf buffer which was not mapped
2083 * remember it in case we need one later
2092 PerlIOMmap_fill(PerlIO *f)
2094 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2095 IV code = PerlIO_flush(f);
2096 if (code == 0 && !b->buf)
2098 code = PerlIOMmap_map(f);
2100 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2102 code = PerlIOBuf_fill(f);
2108 PerlIOMmap_close(PerlIO *f)
2110 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2111 PerlIOBuf *b = &m->base;
2112 IV code = PerlIO_flush(f);
2117 b->ptr = b->end = b->buf;
2119 if (PerlIOBuf_close(f) != 0)
2125 PerlIO_funcs PerlIO_mmap = {
2145 PerlIOBase_clearerr,
2146 PerlIOBuf_setlinebuf,
2147 PerlIOMmap_get_base,
2151 PerlIOBuf_set_ptrcnt,
2154 #endif /* HAS_MMAP */
2161 atexit(&PerlIO_cleanup);
2170 PerlIO_stdstreams();
2174 #undef PerlIO_stdout
2179 PerlIO_stdstreams();
2183 #undef PerlIO_stderr
2188 PerlIO_stdstreams();
2192 /*--------------------------------------------------------------------------------------*/
2194 #undef PerlIO_getname
2196 PerlIO_getname(PerlIO *f, char *buf)
2199 Perl_croak(aTHX_ "Don't know how to get file name");
2204 /*--------------------------------------------------------------------------------------*/
2205 /* Functions which can be called on any kind of PerlIO implemented
2211 PerlIO_getc(PerlIO *f)
2214 SSize_t count = PerlIO_read(f,buf,1);
2217 return (unsigned char) buf[0];
2222 #undef PerlIO_ungetc
2224 PerlIO_ungetc(PerlIO *f, int ch)
2229 if (PerlIO_unread(f,&buf,1) == 1)
2237 PerlIO_putc(PerlIO *f, int ch)
2240 return PerlIO_write(f,&buf,1);
2245 PerlIO_puts(PerlIO *f, const char *s)
2247 STRLEN len = strlen(s);
2248 return PerlIO_write(f,s,len);
2251 #undef PerlIO_rewind
2253 PerlIO_rewind(PerlIO *f)
2255 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2259 #undef PerlIO_vprintf
2261 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2264 SV *sv = newSVpvn("",0);
2267 sv_vcatpvf(sv, fmt, &ap);
2269 return PerlIO_write(f,s,len);
2272 #undef PerlIO_printf
2274 PerlIO_printf(PerlIO *f,const char *fmt,...)
2279 result = PerlIO_vprintf(f,fmt,ap);
2284 #undef PerlIO_stdoutf
2286 PerlIO_stdoutf(const char *fmt,...)
2291 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2296 #undef PerlIO_tmpfile
2298 PerlIO_tmpfile(void)
2301 /* I have no idea how portable mkstemp() is ... */
2302 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2303 int fd = mkstemp(SvPVX(sv));
2307 f = PerlIO_fdopen(fd,"w+");
2310 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2312 PerlLIO_unlink(SvPVX(sv));
2321 #endif /* USE_SFIO */
2322 #endif /* PERLIO_IS_STDIO */
2324 /*======================================================================================*/
2325 /* Now some functions in terms of above which may be needed even if
2326 we are not in true PerlIO mode
2330 #undef PerlIO_setpos
2332 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2334 return PerlIO_seek(f,*pos,0);
2337 #ifndef PERLIO_IS_STDIO
2338 #undef PerlIO_setpos
2340 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2342 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2343 return fsetpos64(f, pos);
2345 return fsetpos(f, pos);
2352 #undef PerlIO_getpos
2354 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2356 *pos = PerlIO_tell(f);
2357 return *pos == -1 ? -1 : 0;
2360 #ifndef PERLIO_IS_STDIO
2361 #undef PerlIO_getpos
2363 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2365 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2366 return fgetpos64(f, pos);
2368 return fgetpos(f, pos);
2374 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2377 vprintf(char *pat, char *args)
2379 _doprnt(pat, args, stdout);
2380 return 0; /* wrong, but perl doesn't use the return value */
2384 vfprintf(FILE *fd, char *pat, char *args)
2386 _doprnt(pat, args, fd);
2387 return 0; /* wrong, but perl doesn't use the return value */
2392 #ifndef PerlIO_vsprintf
2394 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2396 int val = vsprintf(s, fmt, ap);
2399 if (strlen(s) >= (STRLEN)n)
2402 (void)PerlIO_puts(Perl_error_log,
2403 "panic: sprintf overflow - memory corrupted!\n");
2411 #ifndef PerlIO_sprintf
2413 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2418 result = PerlIO_vsprintf(s, n, fmt, ap);
2424 #endif /* !PERL_IMPLICIT_SYS */