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 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
39 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
45 #if !defined(PERL_IMPLICIT_SYS)
47 #ifdef PERLIO_IS_STDIO
52 /* Does nothing (yet) except force this file to be included
53 in perl binary. That allows this file to force inclusion
54 of other functions that may be required by loadable
55 extensions e.g. for FileHandle::tmpfile
66 #else /* PERLIO_IS_STDIO */
73 /* This section is just to make sure these functions
74 get pulled in from libsfio.a
87 /* Force this file to be included in perl binary. Which allows
88 * this file to force inclusion of other functions that may be
89 * required by loadable extensions e.g. for FileHandle::tmpfile
93 * sfio does its own 'autoflush' on stdout in common cases.
94 * Flush results in a lot of lseek()s to regular files and
95 * lot of small writes to pipes.
97 sfset(sfstdout,SF_SHARE,0);
101 /*======================================================================================*/
102 /* Implement all the PerlIO interface ourselves.
107 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
112 #include <sys/mman.h>
117 void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2)));
120 PerlIO_debug(char *fmt,...)
125 char *s = PerlEnv_getenv("PERLIO_DEBUG");
127 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
135 SV *sv = newSVpvn("",0);
139 s = CopFILE(PL_curcop);
142 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
143 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
146 PerlLIO_write(dbg,s,len);
152 /*--------------------------------------------------------------------------------------*/
154 /* Inner level routines */
156 /* Table of pointers to the PerlIO structs (malloc'ed) */
157 PerlIO *_perlio = NULL;
158 #define PERLIO_TABLE_SIZE 64
161 PerlIO_allocate(void)
163 /* Find a free slot in the table, allocating new table as necessary */
164 PerlIO **last = &_perlio;
169 last = (PerlIO **)(f);
170 for (i=1; i < PERLIO_TABLE_SIZE; i++)
178 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
186 PerlIO_cleantable(PerlIO **tablep)
188 PerlIO *table = *tablep;
192 PerlIO_cleantable((PerlIO **) &(table[0]));
193 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
210 PerlIO_cleantable(&_perlio);
214 PerlIO_pop(PerlIO *f)
219 (*l->tab->Popped)(f);
225 /*--------------------------------------------------------------------------------------*/
226 /* XS Interface for perl code */
232 char *s = GvNAME(gv);
233 STRLEN l = GvNAMELEN(gv);
234 PerlIO_debug("%.*s\n",(int) l,s);
238 XS(XS_perlio_unimport)
242 char *s = GvNAME(gv);
243 STRLEN l = GvNAMELEN(gv);
244 PerlIO_debug("%.*s\n",(int) l,s);
249 PerlIO_find_layer(const char *name, STRLEN len)
256 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
257 if (svp && (sv = *svp) && SvROK(sv))
264 perlio_mg_set(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_ "set %_ %p %p %p",sv,io,ifp,ofp);
278 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
282 IO *io = GvIOn((GV *)SvRV(sv));
283 PerlIO *ifp = IoIFP(io);
284 PerlIO *ofp = IoOFP(io);
285 AV *av = (AV *) mg->mg_obj;
286 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
292 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
294 Perl_warn(aTHX_ "clear %_",sv);
299 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
301 Perl_warn(aTHX_ "free %_",sv);
305 MGVTBL perlio_vtab = {
313 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
316 SV *sv = SvRV(ST(1));
321 sv_magic(sv, (SV *)av, '~', NULL, 0);
323 mg = mg_find(sv,'~');
324 mg->mg_virtual = &perlio_vtab;
326 Perl_warn(aTHX_ "attrib %_",sv);
327 for (i=2; i < items; i++)
330 const char *name = SvPV(ST(i),len);
331 SV *layer = PerlIO_find_layer(name,len);
334 av_push(av,SvREFCNT_inc(layer));
347 PerlIO_define_layer(PerlIO_funcs *tab)
350 HV *stash = gv_stashpv("perlio::Layer", TRUE);
351 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
352 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
356 PerlIO_default_layer(I32 n)
361 PerlIO_funcs *tab = &PerlIO_stdio;
363 if (!PerlIO_layer_hv)
365 const char *s = PerlEnv_getenv("PERLIO");
366 newXS("perlio::import",XS_perlio_import,__FILE__);
367 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
369 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
371 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
372 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
373 PerlIO_define_layer(&PerlIO_unix);
374 PerlIO_define_layer(&PerlIO_perlio);
375 PerlIO_define_layer(&PerlIO_stdio);
377 PerlIO_define_layer(&PerlIO_mmap);
379 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
384 while (*s && isSPACE((unsigned char)*s))
390 while (*e && !isSPACE((unsigned char)*e))
394 layer = PerlIO_find_layer(s,e-s);
397 PerlIO_debug("Pushing %.*s\n",(e-s),s);
398 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
401 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
407 len = av_len(PerlIO_layer_av);
410 if (PerlIO_stdio.Set_ptrcnt)
412 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
416 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
418 len = av_len(PerlIO_layer_av);
422 svp = av_fetch(PerlIO_layer_av,n,0);
423 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
425 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
427 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
432 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
436 const char *s = names;
446 while (*e && *e != ':' && !isSPACE(*e))
450 SV *layer = PerlIO_find_layer(s,e-s);
453 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
456 PerlIO *new = PerlIO_push(f,tab,mode);
462 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
471 #define PerlIO_default_top() PerlIO_default_layer(-1)
472 #define PerlIO_default_btm() PerlIO_default_layer(0)
480 PerlIO_fdopen(0,"Ir");
481 PerlIO_fdopen(1,"Iw");
482 PerlIO_fdopen(2,"Iw");
487 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
490 Newc('L',l,tab->size,char,PerlIOl);
493 Zero(l,tab->size,char);
497 if ((*l->tab->Pushed)(f,mode) != 0)
506 /*--------------------------------------------------------------------------------------*/
507 /* Given the abstraction above the public API functions */
511 PerlIO_close(PerlIO *f)
513 int code = (*PerlIOBase(f)->tab->Close)(f);
523 PerlIO_fileno(PerlIO *f)
525 return (*PerlIOBase(f)->tab->Fileno)(f);
532 PerlIO_fdopen(int fd, const char *mode)
534 PerlIO_funcs *tab = PerlIO_default_top();
537 return (*tab->Fdopen)(tab,fd,mode);
542 PerlIO_open(const char *path, const char *mode)
544 PerlIO_funcs *tab = PerlIO_default_top();
547 return (*tab->Open)(tab,path,mode);
552 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
557 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
559 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
565 return PerlIO_open(path,mode);
570 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
572 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
577 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
579 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
584 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
586 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
591 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
593 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
598 PerlIO_tell(PerlIO *f)
600 return (*PerlIOBase(f)->tab->Tell)(f);
605 PerlIO_flush(PerlIO *f)
609 return (*PerlIOBase(f)->tab->Flush)(f);
613 PerlIO **table = &_perlio;
618 table = (PerlIO **)(f++);
619 for (i=1; i < PERLIO_TABLE_SIZE; i++)
621 if (*f && PerlIO_flush(f) != 0)
632 PerlIO_fill(PerlIO *f)
634 return (*PerlIOBase(f)->tab->Fill)(f);
639 PerlIO_isutf8(PerlIO *f)
641 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
646 PerlIO_eof(PerlIO *f)
648 return (*PerlIOBase(f)->tab->Eof)(f);
653 PerlIO_error(PerlIO *f)
655 return (*PerlIOBase(f)->tab->Error)(f);
658 #undef PerlIO_clearerr
660 PerlIO_clearerr(PerlIO *f)
662 (*PerlIOBase(f)->tab->Clearerr)(f);
665 #undef PerlIO_setlinebuf
667 PerlIO_setlinebuf(PerlIO *f)
669 (*PerlIOBase(f)->tab->Setlinebuf)(f);
672 #undef PerlIO_has_base
674 PerlIO_has_base(PerlIO *f)
678 return (PerlIOBase(f)->tab->Get_base != NULL);
683 #undef PerlIO_fast_gets
685 PerlIO_fast_gets(PerlIO *f)
689 PerlIOl *l = PerlIOBase(f);
690 return (l->tab->Set_ptrcnt != NULL);
695 #undef PerlIO_has_cntptr
697 PerlIO_has_cntptr(PerlIO *f)
701 PerlIO_funcs *tab = PerlIOBase(f)->tab;
702 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
707 #undef PerlIO_canset_cnt
709 PerlIO_canset_cnt(PerlIO *f)
713 PerlIOl *l = PerlIOBase(f);
714 return (l->tab->Set_ptrcnt != NULL);
719 #undef PerlIO_get_base
721 PerlIO_get_base(PerlIO *f)
723 return (*PerlIOBase(f)->tab->Get_base)(f);
726 #undef PerlIO_get_bufsiz
728 PerlIO_get_bufsiz(PerlIO *f)
730 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
733 #undef PerlIO_get_ptr
735 PerlIO_get_ptr(PerlIO *f)
737 return (*PerlIOBase(f)->tab->Get_ptr)(f);
740 #undef PerlIO_get_cnt
742 PerlIO_get_cnt(PerlIO *f)
744 return (*PerlIOBase(f)->tab->Get_cnt)(f);
747 #undef PerlIO_set_cnt
749 PerlIO_set_cnt(PerlIO *f,int cnt)
751 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
754 #undef PerlIO_set_ptrcnt
756 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
758 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
761 /*--------------------------------------------------------------------------------------*/
762 /* "Methods" of the "base class" */
765 PerlIOBase_fileno(PerlIO *f)
767 return PerlIO_fileno(PerlIONext(f));
771 PerlIOBase_pushed(PerlIO *f, const char *mode)
773 PerlIOl *l = PerlIOBase(f);
774 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
775 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
781 l->flags = PERLIO_F_CANREAD;
784 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
787 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
798 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
801 l->flags |= PERLIO_F_BINARY;
813 l->flags |= l->next->flags &
814 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
815 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
822 PerlIOBase_popped(PerlIO *f)
828 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
830 Off_t old = PerlIO_tell(f);
831 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
833 Off_t new = PerlIO_tell(f);
840 PerlIOBase_noop_ok(PerlIO *f)
846 PerlIOBase_noop_fail(PerlIO *f)
852 PerlIOBase_close(PerlIO *f)
855 if (PerlIO_flush(f) != 0)
857 if (PerlIO_close(PerlIONext(f)) != 0)
859 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
864 PerlIOBase_eof(PerlIO *f)
868 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
874 PerlIOBase_error(PerlIO *f)
878 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
884 PerlIOBase_clearerr(PerlIO *f)
888 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
893 PerlIOBase_setlinebuf(PerlIO *f)
898 /*--------------------------------------------------------------------------------------*/
899 /* Bottom-most level for UNIX-like case */
903 struct _PerlIO base; /* The generic part */
904 int fd; /* UNIX like file descriptor */
905 int oflags; /* open/fcntl flags */
909 PerlIOUnix_oflags(const char *mode)
924 oflags = O_CREAT|O_TRUNC;
935 oflags = O_CREAT|O_APPEND;
945 if (*mode || oflags == -1)
954 PerlIOUnix_fileno(PerlIO *f)
956 return PerlIOSelf(f,PerlIOUnix)->fd;
960 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
967 int oflags = PerlIOUnix_oflags(mode);
970 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
973 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
980 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
983 int oflags = PerlIOUnix_oflags(mode);
986 int fd = PerlLIO_open3(path,oflags,0666);
989 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
992 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
999 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1001 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1002 int oflags = PerlIOUnix_oflags(mode);
1003 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1004 (*PerlIOBase(f)->tab->Close)(f);
1007 int fd = PerlLIO_open3(path,oflags,0666);
1012 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1020 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1022 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1023 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1027 SSize_t len = PerlLIO_read(fd,vbuf,count);
1028 if (len >= 0 || errno != EINTR)
1031 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1032 else if (len == 0 && count != 0)
1033 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1040 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1042 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1045 SSize_t len = PerlLIO_write(fd,vbuf,count);
1046 if (len >= 0 || errno != EINTR)
1049 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1056 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1058 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1059 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1060 return (new == (Off_t) -1) ? -1 : 0;
1064 PerlIOUnix_tell(PerlIO *f)
1066 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1070 PerlIOUnix_close(PerlIO *f)
1072 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1074 while (PerlLIO_close(fd) != 0)
1084 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1089 PerlIO_funcs PerlIO_unix = {
1105 PerlIOBase_noop_ok, /* flush */
1106 PerlIOBase_noop_fail, /* fill */
1109 PerlIOBase_clearerr,
1110 PerlIOBase_setlinebuf,
1111 NULL, /* get_base */
1112 NULL, /* get_bufsiz */
1115 NULL, /* set_ptrcnt */
1118 /*--------------------------------------------------------------------------------------*/
1119 /* stdio as a layer */
1123 struct _PerlIO base;
1124 FILE * stdio; /* The stream */
1128 PerlIOStdio_fileno(PerlIO *f)
1130 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1135 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1163 stdio = fdopen(fd,mode);
1166 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1173 #undef PerlIO_importFILE
1175 PerlIO_importFILE(FILE *stdio, int fl)
1180 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1187 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1190 FILE *stdio = fopen(path,mode);
1193 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1200 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1202 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1203 FILE *stdio = freopen(path,mode,s->stdio);
1211 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1213 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1217 STDCHAR *buf = (STDCHAR *) vbuf;
1218 /* Perl is expecting PerlIO_getc() to fill the buffer
1219 * Linux's stdio does not do that for fread()
1229 got = fread(vbuf,1,count,s);
1234 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1236 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1237 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1241 int ch = *buf-- & 0xff;
1242 if (ungetc(ch,s) != ch)
1251 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1253 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1257 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1259 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1260 return fseek(stdio,offset,whence);
1264 PerlIOStdio_tell(PerlIO *f)
1266 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1267 return ftell(stdio);
1271 PerlIOStdio_close(PerlIO *f)
1273 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1277 PerlIOStdio_flush(PerlIO *f)
1279 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1280 return fflush(stdio);
1284 PerlIOStdio_fill(PerlIO *f)
1286 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1288 if (fflush(stdio) != 0)
1291 if (c == EOF || ungetc(c,stdio) != c)
1297 PerlIOStdio_eof(PerlIO *f)
1299 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1303 PerlIOStdio_error(PerlIO *f)
1305 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1309 PerlIOStdio_clearerr(PerlIO *f)
1311 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1315 PerlIOStdio_setlinebuf(PerlIO *f)
1317 #ifdef HAS_SETLINEBUF
1318 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1320 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1326 PerlIOStdio_get_base(PerlIO *f)
1328 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1329 return FILE_base(stdio);
1333 PerlIOStdio_get_bufsiz(PerlIO *f)
1335 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1336 return FILE_bufsiz(stdio);
1340 #ifdef USE_STDIO_PTR
1342 PerlIOStdio_get_ptr(PerlIO *f)
1344 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1345 return FILE_ptr(stdio);
1349 PerlIOStdio_get_cnt(PerlIO *f)
1351 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1352 return FILE_cnt(stdio);
1356 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1358 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1361 #ifdef STDIO_PTR_LVALUE
1362 FILE_ptr(stdio) = ptr;
1363 #ifdef STDIO_PTR_LVAL_SETS_CNT
1364 if (FILE_cnt(stdio) != (cnt))
1367 assert(FILE_cnt(stdio) == (cnt));
1370 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1371 /* Setting ptr _does_ change cnt - we are done */
1374 #else /* STDIO_PTR_LVALUE */
1376 #endif /* STDIO_PTR_LVALUE */
1378 /* Now (or only) set cnt */
1379 #ifdef STDIO_CNT_LVALUE
1380 FILE_cnt(stdio) = cnt;
1381 #else /* STDIO_CNT_LVALUE */
1382 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1383 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1384 #else /* STDIO_PTR_LVAL_SETS_CNT */
1386 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1387 #endif /* STDIO_CNT_LVALUE */
1392 PerlIO_funcs PerlIO_stdio = {
1394 sizeof(PerlIOStdio),
1412 PerlIOStdio_clearerr,
1413 PerlIOStdio_setlinebuf,
1415 PerlIOStdio_get_base,
1416 PerlIOStdio_get_bufsiz,
1421 #ifdef USE_STDIO_PTR
1422 PerlIOStdio_get_ptr,
1423 PerlIOStdio_get_cnt,
1424 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1425 PerlIOStdio_set_ptrcnt
1426 #else /* STDIO_PTR_LVALUE */
1428 #endif /* STDIO_PTR_LVALUE */
1429 #else /* USE_STDIO_PTR */
1433 #endif /* USE_STDIO_PTR */
1436 #undef PerlIO_exportFILE
1438 PerlIO_exportFILE(PerlIO *f, int fl)
1441 /* Should really push stdio discipline when we have them */
1442 return fdopen(PerlIO_fileno(f),"r+");
1445 #undef PerlIO_findFILE
1447 PerlIO_findFILE(PerlIO *f)
1449 return PerlIO_exportFILE(f,0);
1452 #undef PerlIO_releaseFILE
1454 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1458 /*--------------------------------------------------------------------------------------*/
1459 /* perlio buffer layer */
1462 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1464 PerlIO_funcs *tab = PerlIO_default_btm();
1472 f = (*tab->Fdopen)(tab,fd,mode);
1475 /* Initial stderr is unbuffered */
1476 if (!init || fd != 2)
1478 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1479 b->posn = PerlIO_tell(PerlIONext(f));
1486 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1488 PerlIO_funcs *tab = PerlIO_default_btm();
1489 PerlIO *f = (*tab->Open)(tab,path,mode);
1492 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1493 b->posn = PerlIO_tell(PerlIONext(f));
1499 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1501 PerlIO *next = PerlIONext(f);
1502 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1504 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1507 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1508 b->posn = PerlIO_tell(PerlIONext(f));
1513 /* This "flush" is akin to sfio's sync in that it handles files in either
1517 PerlIOBuf_flush(PerlIO *f)
1519 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1521 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1523 /* write() the buffer */
1524 STDCHAR *p = b->buf;
1528 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1535 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1540 b->posn += (p - b->buf);
1542 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1544 /* Note position change */
1545 b->posn += (b->ptr - b->buf);
1546 if (b->ptr < b->end)
1548 /* We did not consume all of it */
1549 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1551 b->posn = PerlIO_tell(PerlIONext(f));
1555 b->ptr = b->end = b->buf;
1556 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1557 if (PerlIO_flush(PerlIONext(f)) != 0)
1563 PerlIOBuf_fill(PerlIO *f)
1565 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1567 if (PerlIO_flush(f) != 0)
1569 b->ptr = b->end = b->buf;
1570 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1574 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1576 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1579 b->end = b->buf+avail;
1580 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1585 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1587 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1588 STDCHAR *buf = (STDCHAR *) vbuf;
1594 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1598 SSize_t avail = (b->end - b->ptr);
1599 if ((SSize_t) count < avail)
1603 Copy(b->ptr,buf,avail,char);
1609 if (count && (b->ptr >= b->end))
1611 if (PerlIO_fill(f) != 0)
1621 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1623 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1624 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1627 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1633 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1635 avail = (b->ptr - b->buf);
1636 if (avail > (SSize_t) count)
1643 if (avail > (SSize_t) count)
1645 b->end = b->ptr + avail;
1652 Copy(buf,b->ptr,avail,char);
1656 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1663 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1665 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1666 const STDCHAR *buf = (const STDCHAR *) vbuf;
1670 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1674 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1675 if ((SSize_t) count < avail)
1677 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1678 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1698 Copy(buf,b->ptr,avail,char);
1705 if (b->ptr >= (b->buf + b->bufsiz))
1712 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1714 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1715 int code = PerlIO_flush(f);
1718 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1719 code = PerlIO_seek(PerlIONext(f),offset,whence);
1722 b->posn = PerlIO_tell(PerlIONext(f));
1729 PerlIOBuf_tell(PerlIO *f)
1731 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1732 Off_t posn = b->posn;
1734 posn += (b->ptr - b->buf);
1739 PerlIOBuf_close(PerlIO *f)
1741 IV code = PerlIOBase_close(f);
1742 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1743 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1748 b->ptr = b->end = b->buf;
1749 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1754 PerlIOBuf_setlinebuf(PerlIO *f)
1758 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1763 PerlIOBuf_get_ptr(PerlIO *f)
1765 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1772 PerlIOBuf_get_cnt(PerlIO *f)
1774 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1777 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1778 return (b->end - b->ptr);
1783 PerlIOBuf_get_base(PerlIO *f)
1785 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1790 New('B',b->buf,b->bufsiz,STDCHAR);
1793 b->buf = (STDCHAR *)&b->oneword;
1794 b->bufsiz = sizeof(b->oneword);
1803 PerlIOBuf_bufsiz(PerlIO *f)
1805 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1808 return (b->end - b->buf);
1812 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1814 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1818 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1821 assert(PerlIO_get_cnt(f) == cnt);
1822 assert(b->ptr >= b->buf);
1824 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1827 PerlIO_funcs PerlIO_perlio = {
1847 PerlIOBase_clearerr,
1848 PerlIOBuf_setlinebuf,
1853 PerlIOBuf_set_ptrcnt,
1857 /*--------------------------------------------------------------------------------------*/
1858 /* mmap as "buffer" layer */
1862 PerlIOBuf base; /* PerlIOBuf stuff */
1863 Mmap_t mptr; /* Mapped address */
1864 Size_t len; /* mapped length */
1865 STDCHAR *bbuf; /* malloced buffer if map fails */
1869 static size_t page_size = 0;
1872 PerlIOMmap_map(PerlIO *f)
1875 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1876 PerlIOBuf *b = &m->base;
1877 IV flags = PerlIOBase(f)->flags;
1881 if (flags & PERLIO_F_CANREAD)
1883 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1884 int fd = PerlIO_fileno(f);
1886 code = fstat(fd,&st);
1887 if (code == 0 && S_ISREG(st.st_mode))
1889 SSize_t len = st.st_size - b->posn;
1894 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1896 SETERRNO(0,SS$_NORMAL);
1897 # ifdef _SC_PAGESIZE
1898 page_size = sysconf(_SC_PAGESIZE);
1900 page_size = sysconf(_SC_PAGE_SIZE);
1902 if ((long)page_size < 0) {
1907 (void)SvUPGRADE(error, SVt_PV);
1908 msg = SvPVx(error, n_a);
1909 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1912 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1916 # ifdef HAS_GETPAGESIZE
1917 page_size = getpagesize();
1919 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
1920 page_size = PAGESIZE; /* compiletime, bad */
1924 if ((IV)page_size <= 0)
1925 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1929 /* This is a hack - should never happen - open should have set it ! */
1930 b->posn = PerlIO_tell(PerlIONext(f));
1932 posn = (b->posn / page_size) * page_size;
1933 len = st.st_size - posn;
1934 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1935 if (m->mptr && m->mptr != (Mmap_t) -1)
1937 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1938 madvise(m->mptr, len, MADV_SEQUENTIAL);
1940 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1941 b->end = ((STDCHAR *)m->mptr) + len;
1942 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
1953 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1955 b->ptr = b->end = b->ptr;
1964 PerlIOMmap_unmap(PerlIO *f)
1966 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1967 PerlIOBuf *b = &m->base;
1973 code = munmap(m->mptr, m->len);
1977 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1980 b->ptr = b->end = b->buf;
1981 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1987 PerlIOMmap_get_base(PerlIO *f)
1989 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1990 PerlIOBuf *b = &m->base;
1991 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1993 /* Already have a readbuffer in progress */
1998 /* We have a write buffer or flushed PerlIOBuf read buffer */
1999 m->bbuf = b->buf; /* save it in case we need it again */
2000 b->buf = NULL; /* Clear to trigger below */
2004 PerlIOMmap_map(f); /* Try and map it */
2007 /* Map did not work - recover PerlIOBuf buffer if we have one */
2011 b->ptr = b->end = b->buf;
2014 return PerlIOBuf_get_base(f);
2018 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2020 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2021 PerlIOBuf *b = &m->base;
2022 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2024 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2027 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2032 /* Loose the unwritable mapped buffer */
2034 /* If flush took the "buffer" see if we have one from before */
2035 if (!b->buf && m->bbuf)
2039 PerlIOBuf_get_base(f);
2043 return PerlIOBuf_unread(f,vbuf,count);
2047 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2049 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2050 PerlIOBuf *b = &m->base;
2051 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2053 /* No, or wrong sort of, buffer */
2056 if (PerlIOMmap_unmap(f) != 0)
2059 /* If unmap took the "buffer" see if we have one from before */
2060 if (!b->buf && m->bbuf)
2064 PerlIOBuf_get_base(f);
2068 return PerlIOBuf_write(f,vbuf,count);
2072 PerlIOMmap_flush(PerlIO *f)
2074 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2075 PerlIOBuf *b = &m->base;
2076 IV code = PerlIOBuf_flush(f);
2077 /* Now we are "synced" at PerlIOBuf level */
2082 /* Unmap the buffer */
2083 if (PerlIOMmap_unmap(f) != 0)
2088 /* We seem to have a PerlIOBuf buffer which was not mapped
2089 * remember it in case we need one later
2098 PerlIOMmap_fill(PerlIO *f)
2100 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2101 IV code = PerlIO_flush(f);
2102 if (code == 0 && !b->buf)
2104 code = PerlIOMmap_map(f);
2106 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2108 code = PerlIOBuf_fill(f);
2114 PerlIOMmap_close(PerlIO *f)
2116 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2117 PerlIOBuf *b = &m->base;
2118 IV code = PerlIO_flush(f);
2123 b->ptr = b->end = b->buf;
2125 if (PerlIOBuf_close(f) != 0)
2131 PerlIO_funcs PerlIO_mmap = {
2151 PerlIOBase_clearerr,
2152 PerlIOBuf_setlinebuf,
2153 PerlIOMmap_get_base,
2157 PerlIOBuf_set_ptrcnt,
2160 #endif /* HAS_MMAP */
2167 atexit(&PerlIO_cleanup);
2176 PerlIO_stdstreams();
2180 #undef PerlIO_stdout
2185 PerlIO_stdstreams();
2189 #undef PerlIO_stderr
2194 PerlIO_stdstreams();
2198 /*--------------------------------------------------------------------------------------*/
2200 #undef PerlIO_getname
2202 PerlIO_getname(PerlIO *f, char *buf)
2205 Perl_croak(aTHX_ "Don't know how to get file name");
2210 /*--------------------------------------------------------------------------------------*/
2211 /* Functions which can be called on any kind of PerlIO implemented
2217 PerlIO_getc(PerlIO *f)
2220 SSize_t count = PerlIO_read(f,buf,1);
2223 return (unsigned char) buf[0];
2228 #undef PerlIO_ungetc
2230 PerlIO_ungetc(PerlIO *f, int ch)
2235 if (PerlIO_unread(f,&buf,1) == 1)
2243 PerlIO_putc(PerlIO *f, int ch)
2246 return PerlIO_write(f,&buf,1);
2251 PerlIO_puts(PerlIO *f, const char *s)
2253 STRLEN len = strlen(s);
2254 return PerlIO_write(f,s,len);
2257 #undef PerlIO_rewind
2259 PerlIO_rewind(PerlIO *f)
2261 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2265 #undef PerlIO_vprintf
2267 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2270 SV *sv = newSVpvn("",0);
2273 sv_vcatpvf(sv, fmt, &ap);
2275 return PerlIO_write(f,s,len);
2278 #undef PerlIO_printf
2280 PerlIO_printf(PerlIO *f,const char *fmt,...)
2285 result = PerlIO_vprintf(f,fmt,ap);
2290 #undef PerlIO_stdoutf
2292 PerlIO_stdoutf(const char *fmt,...)
2297 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2302 #undef PerlIO_tmpfile
2304 PerlIO_tmpfile(void)
2307 /* I have no idea how portable mkstemp() is ... */
2308 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2309 int fd = mkstemp(SvPVX(sv));
2313 f = PerlIO_fdopen(fd,"w+");
2316 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2318 PerlLIO_unlink(SvPVX(sv));
2327 #endif /* USE_SFIO */
2328 #endif /* PERLIO_IS_STDIO */
2330 /*======================================================================================*/
2331 /* Now some functions in terms of above which may be needed even if
2332 we are not in true PerlIO mode
2336 #undef PerlIO_setpos
2338 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2340 return PerlIO_seek(f,*pos,0);
2343 #ifndef PERLIO_IS_STDIO
2344 #undef PerlIO_setpos
2346 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2348 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2349 return fsetpos64(f, pos);
2351 return fsetpos(f, pos);
2358 #undef PerlIO_getpos
2360 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2362 *pos = PerlIO_tell(f);
2363 return *pos == -1 ? -1 : 0;
2366 #ifndef PERLIO_IS_STDIO
2367 #undef PerlIO_getpos
2369 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2371 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2372 return fgetpos64(f, pos);
2374 return fgetpos(f, pos);
2380 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2383 vprintf(char *pat, char *args)
2385 _doprnt(pat, args, stdout);
2386 return 0; /* wrong, but perl doesn't use the return value */
2390 vfprintf(FILE *fd, char *pat, char *args)
2392 _doprnt(pat, args, fd);
2393 return 0; /* wrong, but perl doesn't use the return value */
2398 #ifndef PerlIO_vsprintf
2400 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2402 int val = vsprintf(s, fmt, ap);
2405 if (strlen(s) >= (STRLEN)n)
2408 (void)PerlIO_puts(Perl_error_log,
2409 "panic: sprintf overflow - memory corrupted!\n");
2417 #ifndef PerlIO_sprintf
2419 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2424 result = PerlIO_vsprintf(s, n, fmt, ap);
2430 #endif /* !PERL_IMPLICIT_SYS */