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 perlio.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 perlsio_binmode(FILE *fp, int iotype, int mode)
47 /* This used to be contents of do_binmode in doio.c */
49 # if defined(atarist) || defined(__MINT__)
52 ((FILE*)fp)->_flag |= _IOBIN;
54 ((FILE*)fp)->_flag &= ~ _IOBIN;
59 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
60 # if defined(WIN32) && defined(__BORLANDC__)
61 /* The translation mode of the stream is maintained independent
62 * of the translation mode of the fd in the Borland RTL (heavy
63 * digging through their runtime sources reveal). User has to
64 * set the mode explicitly for the stream (though they don't
65 * document this anywhere). GSAR 97-5-24
71 fp->flags &= ~ _F_BIN;
79 # if defined(USEMYBINMODE)
80 if (my_binmode(fp, iotype, mode) != FALSE)
91 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
93 return perlsio_binmode(fp,iotype,mode);
98 #if !defined(PERL_IMPLICIT_SYS)
100 #ifdef PERLIO_IS_STDIO
105 /* Does nothing (yet) except force this file to be included
106 in perl binary. That allows this file to force inclusion
107 of other functions that may be required by loadable
108 extensions e.g. for FileHandle::tmpfile
112 #undef PerlIO_tmpfile
119 #else /* PERLIO_IS_STDIO */
126 /* This section is just to make sure these functions
127 get pulled in from libsfio.a
130 #undef PerlIO_tmpfile
140 /* Force this file to be included in perl binary. Which allows
141 * this file to force inclusion of other functions that may be
142 * required by loadable extensions e.g. for FileHandle::tmpfile
146 * sfio does its own 'autoflush' on stdout in common cases.
147 * Flush results in a lot of lseek()s to regular files and
148 * lot of small writes to pipes.
150 sfset(sfstdout,SF_SHARE,0);
154 /*======================================================================================*/
155 /* Implement all the PerlIO interface ourselves.
160 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
165 #include <sys/mman.h>
170 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
173 PerlIO_debug(const char *fmt,...)
180 char *s = PerlEnv_getenv("PERLIO_DEBUG");
182 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
189 SV *sv = newSVpvn("",0);
192 s = CopFILE(PL_curcop);
195 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
196 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
199 PerlLIO_write(dbg,s,len);
205 /*--------------------------------------------------------------------------------------*/
207 /* Inner level routines */
209 /* Table of pointers to the PerlIO structs (malloc'ed) */
210 PerlIO *_perlio = NULL;
211 #define PERLIO_TABLE_SIZE 64
214 PerlIO_allocate(void)
216 /* Find a free slot in the table, allocating new table as necessary */
217 PerlIO **last = &_perlio;
222 last = (PerlIO **)(f);
223 for (i=1; i < PERLIO_TABLE_SIZE; i++)
231 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
239 PerlIO_cleantable(PerlIO **tablep)
241 PerlIO *table = *tablep;
245 PerlIO_cleantable((PerlIO **) &(table[0]));
246 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
265 PerlIO_cleantable(&_perlio);
269 PerlIO_pop(PerlIO *f)
274 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
275 (*l->tab->Popped)(f);
281 /*--------------------------------------------------------------------------------------*/
282 /* XS Interface for perl code */
288 char *s = GvNAME(gv);
289 STRLEN l = GvNAMELEN(gv);
290 PerlIO_debug("%.*s\n",(int) l,s);
294 XS(XS_perlio_unimport)
298 char *s = GvNAME(gv);
299 STRLEN l = GvNAMELEN(gv);
300 PerlIO_debug("%.*s\n",(int) l,s);
305 PerlIO_find_layer(const char *name, STRLEN len)
312 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
313 if (svp && (sv = *svp) && SvROK(sv))
320 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
324 IO *io = GvIOn((GV *)SvRV(sv));
325 PerlIO *ifp = IoIFP(io);
326 PerlIO *ofp = IoOFP(io);
327 AV *av = (AV *) mg->mg_obj;
328 Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
334 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
338 IO *io = GvIOn((GV *)SvRV(sv));
339 PerlIO *ifp = IoIFP(io);
340 PerlIO *ofp = IoOFP(io);
341 AV *av = (AV *) mg->mg_obj;
342 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
348 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
350 Perl_warn(aTHX_ "clear %_",sv);
355 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
357 Perl_warn(aTHX_ "free %_",sv);
361 MGVTBL perlio_vtab = {
369 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
372 SV *sv = SvRV(ST(1));
377 sv_magic(sv, (SV *)av, '~', NULL, 0);
379 mg = mg_find(sv,'~');
380 mg->mg_virtual = &perlio_vtab;
382 Perl_warn(aTHX_ "attrib %_",sv);
383 for (i=2; i < items; i++)
386 const char *name = SvPV(ST(i),len);
387 SV *layer = PerlIO_find_layer(name,len);
390 av_push(av,SvREFCNT_inc(layer));
403 PerlIO_define_layer(PerlIO_funcs *tab)
406 HV *stash = gv_stashpv("perlio::Layer", TRUE);
407 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
408 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
412 PerlIO_default_layer(I32 n)
417 PerlIO_funcs *tab = &PerlIO_stdio;
419 if (!PerlIO_layer_hv)
421 const char *s = PerlEnv_getenv("PERLIO");
422 newXS("perlio::import",XS_perlio_import,__FILE__);
423 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
425 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
427 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
428 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
429 PerlIO_define_layer(&PerlIO_unix);
430 PerlIO_define_layer(&PerlIO_perlio);
431 PerlIO_define_layer(&PerlIO_stdio);
432 PerlIO_define_layer(&PerlIO_crlf);
434 PerlIO_define_layer(&PerlIO_mmap);
436 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
441 while (*s && isSPACE((unsigned char)*s))
447 while (*e && !isSPACE((unsigned char)*e))
451 layer = PerlIO_find_layer(s,e-s);
454 PerlIO_debug("Pushing %.*s\n",(e-s),s);
455 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
458 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
464 len = av_len(PerlIO_layer_av);
467 if (O_BINARY != O_TEXT)
469 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
473 if (PerlIO_stdio.Set_ptrcnt)
475 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
479 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
482 len = av_len(PerlIO_layer_av);
486 svp = av_fetch(PerlIO_layer_av,n,0);
487 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
489 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
491 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
495 #define PerlIO_default_top() PerlIO_default_layer(-1)
496 #define PerlIO_default_btm() PerlIO_default_layer(0)
504 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
505 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
506 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
511 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
514 Newc('L',l,tab->size,char,PerlIOl);
517 Zero(l,tab->size,char);
521 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
522 if ((*l->tab->Pushed)(f,mode) != 0)
532 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
536 const char *s = names;
546 while (*e && *e != ':' && !isSPACE(*e))
550 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
552 /* Pop back to bottom layer */
556 while (PerlIONext(f))
564 SV *layer = PerlIO_find_layer(s,e-s);
567 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
570 PerlIO *new = PerlIO_push(f,tab,mode);
576 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
588 /*--------------------------------------------------------------------------------------*/
589 /* Given the abstraction above the public API functions */
592 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
594 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
595 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
596 if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
602 if (PerlIOBase(top)->tab == &PerlIO_crlf)
605 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
608 top = PerlIONext(top);
611 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
616 PerlIO__close(PerlIO *f)
618 return (*PerlIOBase(f)->tab->Close)(f);
624 PerlIO_close(PerlIO *f)
626 int code = (*PerlIOBase(f)->tab->Close)(f);
636 PerlIO_fileno(PerlIO *f)
638 return (*PerlIOBase(f)->tab->Fileno)(f);
645 PerlIO_fdopen(int fd, const char *mode)
647 PerlIO_funcs *tab = PerlIO_default_top();
650 return (*tab->Fdopen)(tab,fd,mode);
655 PerlIO_open(const char *path, const char *mode)
657 PerlIO_funcs *tab = PerlIO_default_top();
660 return (*tab->Open)(tab,path,mode);
665 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
670 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
672 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
678 return PerlIO_open(path,mode);
683 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
685 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
690 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
692 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
697 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
699 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
704 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
706 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
711 PerlIO_tell(PerlIO *f)
713 return (*PerlIOBase(f)->tab->Tell)(f);
718 PerlIO_flush(PerlIO *f)
722 return (*PerlIOBase(f)->tab->Flush)(f);
726 PerlIO **table = &_perlio;
731 table = (PerlIO **)(f++);
732 for (i=1; i < PERLIO_TABLE_SIZE; i++)
734 if (*f && PerlIO_flush(f) != 0)
745 PerlIO_fill(PerlIO *f)
747 return (*PerlIOBase(f)->tab->Fill)(f);
752 PerlIO_isutf8(PerlIO *f)
754 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
759 PerlIO_eof(PerlIO *f)
761 return (*PerlIOBase(f)->tab->Eof)(f);
766 PerlIO_error(PerlIO *f)
768 return (*PerlIOBase(f)->tab->Error)(f);
771 #undef PerlIO_clearerr
773 PerlIO_clearerr(PerlIO *f)
776 (*PerlIOBase(f)->tab->Clearerr)(f);
779 #undef PerlIO_setlinebuf
781 PerlIO_setlinebuf(PerlIO *f)
783 (*PerlIOBase(f)->tab->Setlinebuf)(f);
786 #undef PerlIO_has_base
788 PerlIO_has_base(PerlIO *f)
792 return (PerlIOBase(f)->tab->Get_base != NULL);
797 #undef PerlIO_fast_gets
799 PerlIO_fast_gets(PerlIO *f)
803 PerlIOl *l = PerlIOBase(f);
804 return (l->tab->Set_ptrcnt != NULL);
809 #undef PerlIO_has_cntptr
811 PerlIO_has_cntptr(PerlIO *f)
815 PerlIO_funcs *tab = PerlIOBase(f)->tab;
816 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
821 #undef PerlIO_canset_cnt
823 PerlIO_canset_cnt(PerlIO *f)
827 PerlIOl *l = PerlIOBase(f);
828 return (l->tab->Set_ptrcnt != NULL);
833 #undef PerlIO_get_base
835 PerlIO_get_base(PerlIO *f)
837 return (*PerlIOBase(f)->tab->Get_base)(f);
840 #undef PerlIO_get_bufsiz
842 PerlIO_get_bufsiz(PerlIO *f)
844 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
847 #undef PerlIO_get_ptr
849 PerlIO_get_ptr(PerlIO *f)
851 return (*PerlIOBase(f)->tab->Get_ptr)(f);
854 #undef PerlIO_get_cnt
856 PerlIO_get_cnt(PerlIO *f)
858 return (*PerlIOBase(f)->tab->Get_cnt)(f);
861 #undef PerlIO_set_cnt
863 PerlIO_set_cnt(PerlIO *f,int cnt)
865 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
868 #undef PerlIO_set_ptrcnt
870 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
872 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
875 /*--------------------------------------------------------------------------------------*/
876 /* "Methods" of the "base class" */
879 PerlIOBase_fileno(PerlIO *f)
881 return PerlIO_fileno(PerlIONext(f));
885 PerlIO_modestr(PerlIO *f,char *buf)
888 IV flags = PerlIOBase(f)->flags;
889 if (flags & PERLIO_F_CANREAD)
891 if (flags & PERLIO_F_CANWRITE)
893 if (flags & PERLIO_F_CRLF)
902 PerlIOBase_pushed(PerlIO *f, const char *mode)
904 PerlIOl *l = PerlIOBase(f);
905 const char *omode = mode;
907 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
908 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
914 l->flags |= PERLIO_F_CANREAD;
917 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
920 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
931 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
934 l->flags &= ~PERLIO_F_CRLF;
937 l->flags |= PERLIO_F_CRLF;
949 l->flags |= l->next->flags &
950 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
953 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08x (%s)\n",
954 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
955 l->flags,PerlIO_modestr(f,temp));
960 PerlIOBase_popped(PerlIO *f)
966 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
968 Off_t old = PerlIO_tell(f);
969 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
971 Off_t new = PerlIO_tell(f);
978 PerlIOBase_noop_ok(PerlIO *f)
984 PerlIOBase_noop_fail(PerlIO *f)
990 PerlIOBase_close(PerlIO *f)
993 PerlIO *n = PerlIONext(f);
994 if (PerlIO_flush(f) != 0)
996 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
998 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1003 PerlIOBase_eof(PerlIO *f)
1007 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1013 PerlIOBase_error(PerlIO *f)
1017 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1023 PerlIOBase_clearerr(PerlIO *f)
1027 PerlIO *n = PerlIONext(f);
1028 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1035 PerlIOBase_setlinebuf(PerlIO *f)
1040 /*--------------------------------------------------------------------------------------*/
1041 /* Bottom-most level for UNIX-like case */
1045 struct _PerlIO base; /* The generic part */
1046 int fd; /* UNIX like file descriptor */
1047 int oflags; /* open/fcntl flags */
1051 PerlIOUnix_oflags(const char *mode)
1066 oflags = O_CREAT|O_TRUNC;
1077 oflags = O_CREAT|O_APPEND;
1093 else if (*mode == 't')
1096 oflags &= ~O_BINARY;
1099 /* Always open in binary mode */
1101 if (*mode || oflags == -1)
1110 PerlIOUnix_fileno(PerlIO *f)
1112 return PerlIOSelf(f,PerlIOUnix)->fd;
1116 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1123 int oflags = PerlIOUnix_oflags(mode);
1126 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1129 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1136 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1139 int oflags = PerlIOUnix_oflags(mode);
1142 int fd = PerlLIO_open3(path,oflags,0666);
1145 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1148 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1155 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1157 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1158 int oflags = PerlIOUnix_oflags(mode);
1159 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1160 (*PerlIOBase(f)->tab->Close)(f);
1163 int fd = PerlLIO_open3(path,oflags,0666);
1168 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1176 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1178 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1179 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1183 SSize_t len = PerlLIO_read(fd,vbuf,count);
1184 if (len >= 0 || errno != EINTR)
1187 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1188 else if (len == 0 && count != 0)
1189 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1196 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1198 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1201 SSize_t len = PerlLIO_write(fd,vbuf,count);
1202 if (len >= 0 || errno != EINTR)
1205 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1212 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1214 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1215 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1216 return (new == (Off_t) -1) ? -1 : 0;
1220 PerlIOUnix_tell(PerlIO *f)
1222 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1226 PerlIOUnix_close(PerlIO *f)
1228 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1230 while (PerlLIO_close(fd) != 0)
1240 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1245 PerlIO_funcs PerlIO_unix = {
1261 PerlIOBase_noop_ok, /* flush */
1262 PerlIOBase_noop_fail, /* fill */
1265 PerlIOBase_clearerr,
1266 PerlIOBase_setlinebuf,
1267 NULL, /* get_base */
1268 NULL, /* get_bufsiz */
1271 NULL, /* set_ptrcnt */
1274 /*--------------------------------------------------------------------------------------*/
1275 /* stdio as a layer */
1279 struct _PerlIO base;
1280 FILE * stdio; /* The stream */
1284 PerlIOStdio_fileno(PerlIO *f)
1286 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1290 PerlIOStdio_mode(const char *mode,char *tmode)
1292 const char *ret = mode;
1293 if (O_BINARY != O_TEXT)
1295 ret = (const char *) tmode;
1307 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1337 stdio = fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1341 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1348 #undef PerlIO_importFILE
1350 PerlIO_importFILE(FILE *stdio, int fl)
1355 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1362 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1365 FILE *stdio = fopen(path,mode);
1369 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
1370 (mode = PerlIOStdio_mode(mode,tmode))),
1378 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1380 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1382 FILE *stdio = freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1390 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1392 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1396 STDCHAR *buf = (STDCHAR *) vbuf;
1397 /* Perl is expecting PerlIO_getc() to fill the buffer
1398 * Linux's stdio does not do that for fread()
1408 got = fread(vbuf,1,count,s);
1413 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1415 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1416 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1420 int ch = *buf-- & 0xff;
1421 if (ungetc(ch,s) != ch)
1430 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1432 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1436 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1438 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1439 return fseek(stdio,offset,whence);
1443 PerlIOStdio_tell(PerlIO *f)
1445 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1446 return ftell(stdio);
1450 PerlIOStdio_close(PerlIO *f)
1452 int optval, optlen = sizeof(int);
1453 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1455 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1457 close(PerlIO_fileno(f)));
1461 PerlIOStdio_flush(PerlIO *f)
1463 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1464 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1466 return fflush(stdio);
1471 /* FIXME: This discards ungetc() and pre-read stuff which is
1472 not right if this is just a "sync" from a layer above
1473 Suspect right design is to do _this_ but not have layer above
1474 flush this layer read-to-read
1476 /* Not writeable - sync by attempting a seek */
1478 if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1486 PerlIOStdio_fill(PerlIO *f)
1488 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1490 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1491 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1493 if (fflush(stdio) != 0)
1497 if (c == EOF || ungetc(c,stdio) != c)
1503 PerlIOStdio_eof(PerlIO *f)
1505 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1509 PerlIOStdio_error(PerlIO *f)
1511 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1515 PerlIOStdio_clearerr(PerlIO *f)
1517 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1521 PerlIOStdio_setlinebuf(PerlIO *f)
1523 #ifdef HAS_SETLINEBUF
1524 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1526 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1532 PerlIOStdio_get_base(PerlIO *f)
1534 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1535 return FILE_base(stdio);
1539 PerlIOStdio_get_bufsiz(PerlIO *f)
1541 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1542 return FILE_bufsiz(stdio);
1546 #ifdef USE_STDIO_PTR
1548 PerlIOStdio_get_ptr(PerlIO *f)
1550 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1551 return FILE_ptr(stdio);
1555 PerlIOStdio_get_cnt(PerlIO *f)
1557 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1558 return FILE_cnt(stdio);
1562 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1564 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1567 #ifdef STDIO_PTR_LVALUE
1568 FILE_ptr(stdio) = ptr;
1569 #ifdef STDIO_PTR_LVAL_SETS_CNT
1570 if (FILE_cnt(stdio) != (cnt))
1573 assert(FILE_cnt(stdio) == (cnt));
1576 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1577 /* Setting ptr _does_ change cnt - we are done */
1580 #else /* STDIO_PTR_LVALUE */
1582 #endif /* STDIO_PTR_LVALUE */
1584 /* Now (or only) set cnt */
1585 #ifdef STDIO_CNT_LVALUE
1586 FILE_cnt(stdio) = cnt;
1587 #else /* STDIO_CNT_LVALUE */
1588 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1589 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1590 #else /* STDIO_PTR_LVAL_SETS_CNT */
1592 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1593 #endif /* STDIO_CNT_LVALUE */
1598 PerlIO_funcs PerlIO_stdio = {
1600 sizeof(PerlIOStdio),
1618 PerlIOStdio_clearerr,
1619 PerlIOStdio_setlinebuf,
1621 PerlIOStdio_get_base,
1622 PerlIOStdio_get_bufsiz,
1627 #ifdef USE_STDIO_PTR
1628 PerlIOStdio_get_ptr,
1629 PerlIOStdio_get_cnt,
1630 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1631 PerlIOStdio_set_ptrcnt
1632 #else /* STDIO_PTR_LVALUE */
1634 #endif /* STDIO_PTR_LVALUE */
1635 #else /* USE_STDIO_PTR */
1639 #endif /* USE_STDIO_PTR */
1642 #undef PerlIO_exportFILE
1644 PerlIO_exportFILE(PerlIO *f, int fl)
1647 /* Should really push stdio discipline when we have them */
1648 return fdopen(PerlIO_fileno(f),"r+");
1651 #undef PerlIO_findFILE
1653 PerlIO_findFILE(PerlIO *f)
1655 return PerlIO_exportFILE(f,0);
1658 #undef PerlIO_releaseFILE
1660 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1664 /*--------------------------------------------------------------------------------------*/
1665 /* perlio buffer layer */
1668 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1670 PerlIO_funcs *tab = PerlIO_default_btm();
1678 #if O_BINARY != O_TEXT
1680 int code = PerlLIO_setmode(fd, O_BINARY);
1681 /* do something about failing setmode()? --jhi */
1682 PerlIO_debug("PerlIOBuf_fdopen %s fd=%d m=%s c=%d\n",tab->name,fd,mode,code);
1685 f = (*tab->Fdopen)(tab,fd,mode);
1688 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1689 b->posn = PerlIO_tell(PerlIONext(f));
1690 if (init && fd == 2)
1692 /* Initial stderr is unbuffered */
1693 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1695 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08x\n",
1696 self->name,f,fd,mode,PerlIOBase(f)->flags);
1702 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1704 PerlIO_funcs *tab = PerlIO_default_btm();
1705 PerlIO *f = (*tab->Open)(tab,path,mode);
1708 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1709 b->posn = PerlIO_tell(PerlIONext(f));
1715 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1717 PerlIO *next = PerlIONext(f);
1718 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1720 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1723 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1724 b->posn = PerlIO_tell(PerlIONext(f));
1729 /* This "flush" is akin to sfio's sync in that it handles files in either
1733 PerlIOBuf_flush(PerlIO *f)
1735 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1737 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1739 /* write() the buffer */
1740 STDCHAR *p = b->buf;
1742 PerlIO *n = PerlIONext(f);
1745 count = PerlIO_write(n,p,b->ptr - p);
1750 else if (count < 0 || PerlIO_error(n))
1752 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1757 b->posn += (p - b->buf);
1759 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1761 /* Note position change */
1762 b->posn += (b->ptr - b->buf);
1763 if (b->ptr < b->end)
1765 /* We did not consume all of it */
1766 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1768 b->posn = PerlIO_tell(PerlIONext(f));
1772 b->ptr = b->end = b->buf;
1773 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1774 /* FIXME: Is this right for read case ? */
1775 if (PerlIO_flush(PerlIONext(f)) != 0)
1781 PerlIOBuf_fill(PerlIO *f)
1783 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1784 PerlIO *n = PerlIONext(f);
1786 /* FIXME: doing the down-stream flush is a bad idea if it causes
1787 pre-read data in stdio buffer to be discarded
1788 but this is too simplistic - as it skips _our_ hosekeeping
1789 and breaks tell tests.
1790 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1794 if (PerlIO_flush(f) != 0)
1797 b->ptr = b->end = b->buf;
1798 if (PerlIO_fast_gets(n))
1800 /* Layer below is also buffered
1801 * We do _NOT_ want to call its ->Read() because that will loop
1802 * till it gets what we asked for which may hang on a pipe etc.
1803 * Instead take anything it has to hand, or ask it to fill _once_.
1805 avail = PerlIO_get_cnt(n);
1808 avail = PerlIO_fill(n);
1810 avail = PerlIO_get_cnt(n);
1813 if (!PerlIO_error(n) && PerlIO_eof(n))
1819 STDCHAR *ptr = PerlIO_get_ptr(n);
1820 SSize_t cnt = avail;
1821 if (avail > b->bufsiz)
1823 Copy(ptr,b->buf,avail,STDCHAR);
1824 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1829 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1834 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1836 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1839 b->end = b->buf+avail;
1840 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1845 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1847 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1848 STDCHAR *buf = (STDCHAR *) vbuf;
1853 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1857 SSize_t avail = PerlIO_get_cnt(f);
1858 SSize_t take = (count < avail) ? count : avail;
1861 STDCHAR *ptr = PerlIO_get_ptr(f);
1862 Copy(ptr,buf,take,STDCHAR);
1863 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1867 if (count > 0 && avail <= 0)
1869 if (PerlIO_fill(f) != 0)
1873 return (buf - (STDCHAR *) vbuf);
1879 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1881 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1882 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1885 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1891 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1893 avail = (b->ptr - b->buf);
1894 if (avail > (SSize_t) count)
1901 if (avail > (SSize_t) count)
1903 b->end = b->ptr + avail;
1910 Copy(buf,b->ptr,avail,STDCHAR);
1914 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1921 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1923 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1924 const STDCHAR *buf = (const STDCHAR *) vbuf;
1928 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1932 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1933 if ((SSize_t) count < avail)
1935 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1936 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1956 Copy(buf,b->ptr,avail,STDCHAR);
1963 if (b->ptr >= (b->buf + b->bufsiz))
1966 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
1972 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1974 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1975 int code = PerlIO_flush(f);
1978 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1979 code = PerlIO_seek(PerlIONext(f),offset,whence);
1982 b->posn = PerlIO_tell(PerlIONext(f));
1989 PerlIOBuf_tell(PerlIO *f)
1991 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1992 Off_t posn = b->posn;
1994 posn += (b->ptr - b->buf);
1999 PerlIOBuf_close(PerlIO *f)
2001 IV code = PerlIOBase_close(f);
2002 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2003 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2008 b->ptr = b->end = b->buf;
2009 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2014 PerlIOBuf_setlinebuf(PerlIO *f)
2018 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2023 PerlIOBuf_get_ptr(PerlIO *f)
2025 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2032 PerlIOBuf_get_cnt(PerlIO *f)
2034 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2037 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2038 return (b->end - b->ptr);
2043 PerlIOBuf_get_base(PerlIO *f)
2045 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2050 New('B',b->buf,b->bufsiz,STDCHAR);
2053 b->buf = (STDCHAR *)&b->oneword;
2054 b->bufsiz = sizeof(b->oneword);
2063 PerlIOBuf_bufsiz(PerlIO *f)
2065 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2068 return (b->end - b->buf);
2072 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2074 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2078 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2081 assert(PerlIO_get_cnt(f) == cnt);
2082 assert(b->ptr >= b->buf);
2084 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2087 PerlIO_funcs PerlIO_perlio = {
2107 PerlIOBase_clearerr,
2108 PerlIOBuf_setlinebuf,
2113 PerlIOBuf_set_ptrcnt,
2116 /*--------------------------------------------------------------------------------------*/
2117 /* crlf - translation
2118 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2119 to hand back a line at a time and keeping a record of which nl we "lied" about.
2120 On write translate "\n" to CR,LF
2125 PerlIOBuf base; /* PerlIOBuf stuff */
2126 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2130 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2133 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2134 code = PerlIOBase_pushed(f,mode);
2135 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08x\n",
2136 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2137 PerlIOBase(f)->flags);
2143 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2145 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2151 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2152 return PerlIOBuf_unread(f,vbuf,count);
2155 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2156 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2158 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2164 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2166 b->end = b->ptr = b->buf + b->bufsiz;
2167 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2169 while (count > 0 && b->ptr > b->buf)
2174 if (b->ptr - 2 >= b->buf)
2200 PerlIOCrlf_get_cnt(PerlIO *f)
2202 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2205 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2207 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2208 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2210 STDCHAR *nl = b->ptr;
2212 while (nl < b->end && *nl != 0xd)
2214 if (nl < b->end && *nl == 0xd)
2226 /* Not CR,LF but just CR */
2233 /* Blast - found CR as last char in buffer */
2236 /* They may not care, defer work as long as possible */
2237 return (nl - b->ptr);
2243 b->ptr++; /* say we have read it as far as flush() is concerned */
2244 b->buf++; /* Leave space an front of buffer */
2245 b->bufsiz--; /* Buffer is thus smaller */
2246 code = PerlIO_fill(f); /* Fetch some more */
2247 b->bufsiz++; /* Restore size for next time */
2248 b->buf--; /* Point at space */
2249 b->ptr = nl = b->buf; /* Which is what we hand off */
2250 b->posn--; /* Buffer starts here */
2251 *nl = 0xd; /* Fill in the CR */
2253 goto test; /* fill() call worked */
2254 /* CR at EOF - just fall through */
2259 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2265 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2267 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2268 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2269 IV flags = PerlIOBase(f)->flags;
2279 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2286 /* Test code - delete when it works ... */
2293 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2301 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08x nl=%p e=%p for %d",
2302 ptr, chk, flags, c->nl, b->end, cnt);
2309 /* They have taken what we lied about */
2316 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2320 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2322 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2323 return PerlIOBuf_write(f,vbuf,count);
2326 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2327 const STDCHAR *buf = (const STDCHAR *) vbuf;
2328 const STDCHAR *ebuf = buf+count;
2331 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2335 STDCHAR *eptr = b->buf+b->bufsiz;
2336 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2337 while (buf < ebuf && b->ptr < eptr)
2341 if ((b->ptr + 2) > eptr)
2343 /* Not room for both */
2349 *(b->ptr)++ = 0xd; /* CR */
2350 *(b->ptr)++ = 0xa; /* LF */
2352 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2371 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2373 return (buf - (STDCHAR *) vbuf);
2378 PerlIOCrlf_flush(PerlIO *f)
2380 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2386 return PerlIOBuf_flush(f);
2389 PerlIO_funcs PerlIO_crlf = {
2392 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2398 PerlIOBase_noop_ok, /* popped */
2399 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2400 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2401 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2409 PerlIOBase_clearerr,
2410 PerlIOBuf_setlinebuf,
2415 PerlIOCrlf_set_ptrcnt,
2419 /*--------------------------------------------------------------------------------------*/
2420 /* mmap as "buffer" layer */
2424 PerlIOBuf base; /* PerlIOBuf stuff */
2425 Mmap_t mptr; /* Mapped address */
2426 Size_t len; /* mapped length */
2427 STDCHAR *bbuf; /* malloced buffer if map fails */
2430 static size_t page_size = 0;
2433 PerlIOMmap_map(PerlIO *f)
2436 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2437 PerlIOBuf *b = &m->base;
2438 IV flags = PerlIOBase(f)->flags;
2442 if (flags & PERLIO_F_CANREAD)
2444 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2445 int fd = PerlIO_fileno(f);
2447 code = fstat(fd,&st);
2448 if (code == 0 && S_ISREG(st.st_mode))
2450 SSize_t len = st.st_size - b->posn;
2455 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2457 SETERRNO(0,SS$_NORMAL);
2458 # ifdef _SC_PAGESIZE
2459 page_size = sysconf(_SC_PAGESIZE);
2461 page_size = sysconf(_SC_PAGE_SIZE);
2463 if ((long)page_size < 0) {
2468 (void)SvUPGRADE(error, SVt_PV);
2469 msg = SvPVx(error, n_a);
2470 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2473 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2477 # ifdef HAS_GETPAGESIZE
2478 page_size = getpagesize();
2480 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2481 page_size = PAGESIZE; /* compiletime, bad */
2485 if ((IV)page_size <= 0)
2486 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2490 /* This is a hack - should never happen - open should have set it ! */
2491 b->posn = PerlIO_tell(PerlIONext(f));
2493 posn = (b->posn / page_size) * page_size;
2494 len = st.st_size - posn;
2495 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2496 if (m->mptr && m->mptr != (Mmap_t) -1)
2498 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2499 madvise(m->mptr, len, MADV_SEQUENTIAL);
2501 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2502 b->end = ((STDCHAR *)m->mptr) + len;
2503 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2514 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2516 b->ptr = b->end = b->ptr;
2525 PerlIOMmap_unmap(PerlIO *f)
2527 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2528 PerlIOBuf *b = &m->base;
2534 code = munmap(m->mptr, m->len);
2538 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2541 b->ptr = b->end = b->buf;
2542 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2548 PerlIOMmap_get_base(PerlIO *f)
2550 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2551 PerlIOBuf *b = &m->base;
2552 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2554 /* Already have a readbuffer in progress */
2559 /* We have a write buffer or flushed PerlIOBuf read buffer */
2560 m->bbuf = b->buf; /* save it in case we need it again */
2561 b->buf = NULL; /* Clear to trigger below */
2565 PerlIOMmap_map(f); /* Try and map it */
2568 /* Map did not work - recover PerlIOBuf buffer if we have one */
2572 b->ptr = b->end = b->buf;
2575 return PerlIOBuf_get_base(f);
2579 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2581 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2582 PerlIOBuf *b = &m->base;
2583 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2585 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2588 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2593 /* Loose the unwritable mapped buffer */
2595 /* If flush took the "buffer" see if we have one from before */
2596 if (!b->buf && m->bbuf)
2600 PerlIOBuf_get_base(f);
2604 return PerlIOBuf_unread(f,vbuf,count);
2608 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2610 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2611 PerlIOBuf *b = &m->base;
2612 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2614 /* No, or wrong sort of, buffer */
2617 if (PerlIOMmap_unmap(f) != 0)
2620 /* If unmap took the "buffer" see if we have one from before */
2621 if (!b->buf && m->bbuf)
2625 PerlIOBuf_get_base(f);
2629 return PerlIOBuf_write(f,vbuf,count);
2633 PerlIOMmap_flush(PerlIO *f)
2635 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2636 PerlIOBuf *b = &m->base;
2637 IV code = PerlIOBuf_flush(f);
2638 /* Now we are "synced" at PerlIOBuf level */
2643 /* Unmap the buffer */
2644 if (PerlIOMmap_unmap(f) != 0)
2649 /* We seem to have a PerlIOBuf buffer which was not mapped
2650 * remember it in case we need one later
2659 PerlIOMmap_fill(PerlIO *f)
2661 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2662 IV code = PerlIO_flush(f);
2663 if (code == 0 && !b->buf)
2665 code = PerlIOMmap_map(f);
2667 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2669 code = PerlIOBuf_fill(f);
2675 PerlIOMmap_close(PerlIO *f)
2677 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2678 PerlIOBuf *b = &m->base;
2679 IV code = PerlIO_flush(f);
2684 b->ptr = b->end = b->buf;
2686 if (PerlIOBuf_close(f) != 0)
2692 PerlIO_funcs PerlIO_mmap = {
2712 PerlIOBase_clearerr,
2713 PerlIOBuf_setlinebuf,
2714 PerlIOMmap_get_base,
2718 PerlIOBuf_set_ptrcnt,
2721 #endif /* HAS_MMAP */
2728 atexit(&PerlIO_cleanup);
2737 PerlIO_stdstreams();
2741 #undef PerlIO_stdout
2746 PerlIO_stdstreams();
2750 #undef PerlIO_stderr
2755 PerlIO_stdstreams();
2759 /*--------------------------------------------------------------------------------------*/
2761 #undef PerlIO_getname
2763 PerlIO_getname(PerlIO *f, char *buf)
2766 Perl_croak(aTHX_ "Don't know how to get file name");
2771 /*--------------------------------------------------------------------------------------*/
2772 /* Functions which can be called on any kind of PerlIO implemented
2778 PerlIO_getc(PerlIO *f)
2781 SSize_t count = PerlIO_read(f,buf,1);
2784 return (unsigned char) buf[0];
2789 #undef PerlIO_ungetc
2791 PerlIO_ungetc(PerlIO *f, int ch)
2796 if (PerlIO_unread(f,&buf,1) == 1)
2804 PerlIO_putc(PerlIO *f, int ch)
2807 return PerlIO_write(f,&buf,1);
2812 PerlIO_puts(PerlIO *f, const char *s)
2814 STRLEN len = strlen(s);
2815 return PerlIO_write(f,s,len);
2818 #undef PerlIO_rewind
2820 PerlIO_rewind(PerlIO *f)
2822 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2826 #undef PerlIO_vprintf
2828 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2831 SV *sv = newSVpvn("",0);
2836 Perl_va_copy(ap, apc);
2837 sv_vcatpvf(sv, fmt, &apc);
2839 sv_vcatpvf(sv, fmt, &ap);
2842 return PerlIO_write(f,s,len);
2845 #undef PerlIO_printf
2847 PerlIO_printf(PerlIO *f,const char *fmt,...)
2852 result = PerlIO_vprintf(f,fmt,ap);
2857 #undef PerlIO_stdoutf
2859 PerlIO_stdoutf(const char *fmt,...)
2864 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2869 #undef PerlIO_tmpfile
2871 PerlIO_tmpfile(void)
2873 /* I have no idea how portable mkstemp() is ... */
2874 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2876 FILE *stdio = tmpfile();
2879 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2885 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2886 int fd = mkstemp(SvPVX(sv));
2890 f = PerlIO_fdopen(fd,"w+");
2893 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2895 PerlLIO_unlink(SvPVX(sv));
2905 #endif /* USE_SFIO */
2906 #endif /* PERLIO_IS_STDIO */
2908 /*======================================================================================*/
2909 /* Now some functions in terms of above which may be needed even if
2910 we are not in true PerlIO mode
2914 #undef PerlIO_setpos
2916 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2918 return PerlIO_seek(f,*pos,0);
2921 #ifndef PERLIO_IS_STDIO
2922 #undef PerlIO_setpos
2924 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2926 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2927 return fsetpos64(f, pos);
2929 return fsetpos(f, pos);
2936 #undef PerlIO_getpos
2938 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2940 *pos = PerlIO_tell(f);
2941 return *pos == -1 ? -1 : 0;
2944 #ifndef PERLIO_IS_STDIO
2945 #undef PerlIO_getpos
2947 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2949 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2950 return fgetpos64(f, pos);
2952 return fgetpos(f, pos);
2958 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2961 vprintf(char *pat, char *args)
2963 _doprnt(pat, args, stdout);
2964 return 0; /* wrong, but perl doesn't use the return value */
2968 vfprintf(FILE *fd, char *pat, char *args)
2970 _doprnt(pat, args, fd);
2971 return 0; /* wrong, but perl doesn't use the return value */
2976 #ifndef PerlIO_vsprintf
2978 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2980 int val = vsprintf(s, fmt, ap);
2983 if (strlen(s) >= (STRLEN)n)
2986 (void)PerlIO_puts(Perl_error_log,
2987 "panic: sprintf overflow - memory corrupted!\n");
2995 #ifndef PerlIO_sprintf
2997 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3002 result = PerlIO_vsprintf(s, n, fmt, ap);
3008 #endif /* !PERL_IMPLICIT_SYS */