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 PerlIO_debug("PerlIOBuf_fdopen %s fd=%d m=%s c=%d\n",tab->name,fd,mode,code);
1683 f = (*tab->Fdopen)(tab,fd,mode);
1686 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1687 b->posn = PerlIO_tell(PerlIONext(f));
1688 if (init && fd == 2)
1690 /* Initial stderr is unbuffered */
1691 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1693 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08x\n",
1694 self->name,f,fd,mode,PerlIOBase(f)->flags);
1700 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1702 PerlIO_funcs *tab = PerlIO_default_btm();
1703 PerlIO *f = (*tab->Open)(tab,path,mode);
1706 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1707 b->posn = PerlIO_tell(PerlIONext(f));
1713 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1715 PerlIO *next = PerlIONext(f);
1716 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1718 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1721 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1722 b->posn = PerlIO_tell(PerlIONext(f));
1727 /* This "flush" is akin to sfio's sync in that it handles files in either
1731 PerlIOBuf_flush(PerlIO *f)
1733 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1735 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1737 /* write() the buffer */
1738 STDCHAR *p = b->buf;
1740 PerlIO *n = PerlIONext(f);
1743 count = PerlIO_write(n,p,b->ptr - p);
1748 else if (count < 0 || PerlIO_error(n))
1750 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1755 b->posn += (p - b->buf);
1757 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1759 /* Note position change */
1760 b->posn += (b->ptr - b->buf);
1761 if (b->ptr < b->end)
1763 /* We did not consume all of it */
1764 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1766 b->posn = PerlIO_tell(PerlIONext(f));
1770 b->ptr = b->end = b->buf;
1771 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1772 /* FIXME: Is this right for read case ? */
1773 if (PerlIO_flush(PerlIONext(f)) != 0)
1779 PerlIOBuf_fill(PerlIO *f)
1781 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1782 PerlIO *n = PerlIONext(f);
1784 /* FIXME: doing the down-stream flush is a bad idea if it causes
1785 pre-read data in stdio buffer to be discarded
1786 but this is too simplistic - as it skips _our_ hosekeeping
1787 and breaks tell tests.
1788 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1792 if (PerlIO_flush(f) != 0)
1795 b->ptr = b->end = b->buf;
1796 if (PerlIO_fast_gets(n))
1798 /* Layer below is also buffered
1799 * We do _NOT_ want to call its ->Read() because that will loop
1800 * till it gets what we asked for which may hang on a pipe etc.
1801 * Instead take anything it has to hand, or ask it to fill _once_.
1803 avail = PerlIO_get_cnt(n);
1806 avail = PerlIO_fill(n);
1808 avail = PerlIO_get_cnt(n);
1811 if (!PerlIO_error(n) && PerlIO_eof(n))
1817 STDCHAR *ptr = PerlIO_get_ptr(n);
1818 SSize_t cnt = avail;
1819 if (avail > b->bufsiz)
1821 Copy(ptr,b->buf,avail,STDCHAR);
1822 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1827 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1832 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1834 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1837 b->end = b->buf+avail;
1838 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1843 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1845 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1846 STDCHAR *buf = (STDCHAR *) vbuf;
1851 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1855 SSize_t avail = PerlIO_get_cnt(f);
1856 SSize_t take = (count < avail) ? count : avail;
1859 STDCHAR *ptr = PerlIO_get_ptr(f);
1860 Copy(ptr,buf,take,STDCHAR);
1861 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1865 if (count > 0 && avail <= 0)
1867 if (PerlIO_fill(f) != 0)
1871 return (buf - (STDCHAR *) vbuf);
1877 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1879 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1880 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1883 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1889 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1891 avail = (b->ptr - b->buf);
1892 if (avail > (SSize_t) count)
1899 if (avail > (SSize_t) count)
1901 b->end = b->ptr + avail;
1908 Copy(buf,b->ptr,avail,STDCHAR);
1912 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1919 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1921 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1922 const STDCHAR *buf = (const STDCHAR *) vbuf;
1926 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1930 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1931 if ((SSize_t) count < avail)
1933 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1934 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1954 Copy(buf,b->ptr,avail,STDCHAR);
1961 if (b->ptr >= (b->buf + b->bufsiz))
1964 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
1970 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1972 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1973 int code = PerlIO_flush(f);
1976 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1977 code = PerlIO_seek(PerlIONext(f),offset,whence);
1980 b->posn = PerlIO_tell(PerlIONext(f));
1987 PerlIOBuf_tell(PerlIO *f)
1989 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1990 Off_t posn = b->posn;
1992 posn += (b->ptr - b->buf);
1997 PerlIOBuf_close(PerlIO *f)
1999 IV code = PerlIOBase_close(f);
2000 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2001 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2006 b->ptr = b->end = b->buf;
2007 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2012 PerlIOBuf_setlinebuf(PerlIO *f)
2016 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2021 PerlIOBuf_get_ptr(PerlIO *f)
2023 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2030 PerlIOBuf_get_cnt(PerlIO *f)
2032 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2035 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2036 return (b->end - b->ptr);
2041 PerlIOBuf_get_base(PerlIO *f)
2043 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2048 New('B',b->buf,b->bufsiz,STDCHAR);
2051 b->buf = (STDCHAR *)&b->oneword;
2052 b->bufsiz = sizeof(b->oneword);
2061 PerlIOBuf_bufsiz(PerlIO *f)
2063 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2066 return (b->end - b->buf);
2070 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2072 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2076 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2079 assert(PerlIO_get_cnt(f) == cnt);
2080 assert(b->ptr >= b->buf);
2082 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2085 PerlIO_funcs PerlIO_perlio = {
2105 PerlIOBase_clearerr,
2106 PerlIOBuf_setlinebuf,
2111 PerlIOBuf_set_ptrcnt,
2114 /*--------------------------------------------------------------------------------------*/
2115 /* crlf - translation
2116 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2117 to hand back a line at a time and keeping a record of which nl we "lied" about.
2118 On write translate "\n" to CR,LF
2123 PerlIOBuf base; /* PerlIOBuf stuff */
2124 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2128 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2131 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2132 code = PerlIOBase_pushed(f,mode);
2133 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08x\n",
2134 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2135 PerlIOBase(f)->flags);
2141 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2143 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2149 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2150 return PerlIOBuf_unread(f,vbuf,count);
2153 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2154 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2156 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2162 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2164 b->end = b->ptr = b->buf + b->bufsiz;
2165 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2167 while (count > 0 && b->ptr > b->buf)
2172 if (b->ptr - 2 >= b->buf)
2198 PerlIOCrlf_get_cnt(PerlIO *f)
2200 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2203 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2205 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2206 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2208 STDCHAR *nl = b->ptr;
2210 while (nl < b->end && *nl != 0xd)
2212 if (nl < b->end && *nl == 0xd)
2224 /* Not CR,LF but just CR */
2231 /* Blast - found CR as last char in buffer */
2234 /* They may not care, defer work as long as possible */
2235 return (nl - b->ptr);
2241 b->ptr++; /* say we have read it as far as flush() is concerned */
2242 b->buf++; /* Leave space an front of buffer */
2243 b->bufsiz--; /* Buffer is thus smaller */
2244 code = PerlIO_fill(f); /* Fetch some more */
2245 b->bufsiz++; /* Restore size for next time */
2246 b->buf--; /* Point at space */
2247 b->ptr = nl = b->buf; /* Which is what we hand off */
2248 b->posn--; /* Buffer starts here */
2249 *nl = 0xd; /* Fill in the CR */
2251 goto test; /* fill() call worked */
2252 /* CR at EOF - just fall through */
2257 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2263 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2265 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2266 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2267 IV flags = PerlIOBase(f)->flags;
2277 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2284 /* Test code - delete when it works ... */
2291 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2299 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08x nl=%p e=%p for %d",
2300 ptr, chk, flags, c->nl, b->end, cnt);
2307 /* They have taken what we lied about */
2314 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2318 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2320 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2321 return PerlIOBuf_write(f,vbuf,count);
2324 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2325 const STDCHAR *buf = (const STDCHAR *) vbuf;
2326 const STDCHAR *ebuf = buf+count;
2329 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2333 STDCHAR *eptr = b->buf+b->bufsiz;
2334 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2335 while (buf < ebuf && b->ptr < eptr)
2339 if ((b->ptr + 2) > eptr)
2341 /* Not room for both */
2347 *(b->ptr)++ = 0xd; /* CR */
2348 *(b->ptr)++ = 0xa; /* LF */
2350 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2369 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2371 return (buf - (STDCHAR *) vbuf);
2376 PerlIOCrlf_flush(PerlIO *f)
2378 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2384 return PerlIOBuf_flush(f);
2387 PerlIO_funcs PerlIO_crlf = {
2390 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2396 PerlIOBase_noop_ok, /* popped */
2397 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2398 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2399 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2407 PerlIOBase_clearerr,
2408 PerlIOBuf_setlinebuf,
2413 PerlIOCrlf_set_ptrcnt,
2417 /*--------------------------------------------------------------------------------------*/
2418 /* mmap as "buffer" layer */
2422 PerlIOBuf base; /* PerlIOBuf stuff */
2423 Mmap_t mptr; /* Mapped address */
2424 Size_t len; /* mapped length */
2425 STDCHAR *bbuf; /* malloced buffer if map fails */
2428 static size_t page_size = 0;
2431 PerlIOMmap_map(PerlIO *f)
2434 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2435 PerlIOBuf *b = &m->base;
2436 IV flags = PerlIOBase(f)->flags;
2440 if (flags & PERLIO_F_CANREAD)
2442 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2443 int fd = PerlIO_fileno(f);
2445 code = fstat(fd,&st);
2446 if (code == 0 && S_ISREG(st.st_mode))
2448 SSize_t len = st.st_size - b->posn;
2453 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2455 SETERRNO(0,SS$_NORMAL);
2456 # ifdef _SC_PAGESIZE
2457 page_size = sysconf(_SC_PAGESIZE);
2459 page_size = sysconf(_SC_PAGE_SIZE);
2461 if ((long)page_size < 0) {
2466 (void)SvUPGRADE(error, SVt_PV);
2467 msg = SvPVx(error, n_a);
2468 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2471 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2475 # ifdef HAS_GETPAGESIZE
2476 page_size = getpagesize();
2478 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2479 page_size = PAGESIZE; /* compiletime, bad */
2483 if ((IV)page_size <= 0)
2484 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2488 /* This is a hack - should never happen - open should have set it ! */
2489 b->posn = PerlIO_tell(PerlIONext(f));
2491 posn = (b->posn / page_size) * page_size;
2492 len = st.st_size - posn;
2493 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2494 if (m->mptr && m->mptr != (Mmap_t) -1)
2496 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2497 madvise(m->mptr, len, MADV_SEQUENTIAL);
2499 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2500 b->end = ((STDCHAR *)m->mptr) + len;
2501 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2512 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2514 b->ptr = b->end = b->ptr;
2523 PerlIOMmap_unmap(PerlIO *f)
2525 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2526 PerlIOBuf *b = &m->base;
2532 code = munmap(m->mptr, m->len);
2536 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2539 b->ptr = b->end = b->buf;
2540 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2546 PerlIOMmap_get_base(PerlIO *f)
2548 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2549 PerlIOBuf *b = &m->base;
2550 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2552 /* Already have a readbuffer in progress */
2557 /* We have a write buffer or flushed PerlIOBuf read buffer */
2558 m->bbuf = b->buf; /* save it in case we need it again */
2559 b->buf = NULL; /* Clear to trigger below */
2563 PerlIOMmap_map(f); /* Try and map it */
2566 /* Map did not work - recover PerlIOBuf buffer if we have one */
2570 b->ptr = b->end = b->buf;
2573 return PerlIOBuf_get_base(f);
2577 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2579 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2580 PerlIOBuf *b = &m->base;
2581 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2583 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2586 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2591 /* Loose the unwritable mapped buffer */
2593 /* If flush took the "buffer" see if we have one from before */
2594 if (!b->buf && m->bbuf)
2598 PerlIOBuf_get_base(f);
2602 return PerlIOBuf_unread(f,vbuf,count);
2606 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2608 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2609 PerlIOBuf *b = &m->base;
2610 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2612 /* No, or wrong sort of, buffer */
2615 if (PerlIOMmap_unmap(f) != 0)
2618 /* If unmap took the "buffer" see if we have one from before */
2619 if (!b->buf && m->bbuf)
2623 PerlIOBuf_get_base(f);
2627 return PerlIOBuf_write(f,vbuf,count);
2631 PerlIOMmap_flush(PerlIO *f)
2633 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2634 PerlIOBuf *b = &m->base;
2635 IV code = PerlIOBuf_flush(f);
2636 /* Now we are "synced" at PerlIOBuf level */
2641 /* Unmap the buffer */
2642 if (PerlIOMmap_unmap(f) != 0)
2647 /* We seem to have a PerlIOBuf buffer which was not mapped
2648 * remember it in case we need one later
2657 PerlIOMmap_fill(PerlIO *f)
2659 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2660 IV code = PerlIO_flush(f);
2661 if (code == 0 && !b->buf)
2663 code = PerlIOMmap_map(f);
2665 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2667 code = PerlIOBuf_fill(f);
2673 PerlIOMmap_close(PerlIO *f)
2675 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2676 PerlIOBuf *b = &m->base;
2677 IV code = PerlIO_flush(f);
2682 b->ptr = b->end = b->buf;
2684 if (PerlIOBuf_close(f) != 0)
2690 PerlIO_funcs PerlIO_mmap = {
2710 PerlIOBase_clearerr,
2711 PerlIOBuf_setlinebuf,
2712 PerlIOMmap_get_base,
2716 PerlIOBuf_set_ptrcnt,
2719 #endif /* HAS_MMAP */
2726 atexit(&PerlIO_cleanup);
2735 PerlIO_stdstreams();
2739 #undef PerlIO_stdout
2744 PerlIO_stdstreams();
2748 #undef PerlIO_stderr
2753 PerlIO_stdstreams();
2757 /*--------------------------------------------------------------------------------------*/
2759 #undef PerlIO_getname
2761 PerlIO_getname(PerlIO *f, char *buf)
2764 Perl_croak(aTHX_ "Don't know how to get file name");
2769 /*--------------------------------------------------------------------------------------*/
2770 /* Functions which can be called on any kind of PerlIO implemented
2776 PerlIO_getc(PerlIO *f)
2779 SSize_t count = PerlIO_read(f,buf,1);
2782 return (unsigned char) buf[0];
2787 #undef PerlIO_ungetc
2789 PerlIO_ungetc(PerlIO *f, int ch)
2794 if (PerlIO_unread(f,&buf,1) == 1)
2802 PerlIO_putc(PerlIO *f, int ch)
2805 return PerlIO_write(f,&buf,1);
2810 PerlIO_puts(PerlIO *f, const char *s)
2812 STRLEN len = strlen(s);
2813 return PerlIO_write(f,s,len);
2816 #undef PerlIO_rewind
2818 PerlIO_rewind(PerlIO *f)
2820 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2824 #undef PerlIO_vprintf
2826 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2829 SV *sv = newSVpvn("",0);
2834 Perl_va_copy(ap, apc);
2835 sv_vcatpvf(sv, fmt, &apc);
2837 sv_vcatpvf(sv, fmt, &ap);
2840 return PerlIO_write(f,s,len);
2843 #undef PerlIO_printf
2845 PerlIO_printf(PerlIO *f,const char *fmt,...)
2850 result = PerlIO_vprintf(f,fmt,ap);
2855 #undef PerlIO_stdoutf
2857 PerlIO_stdoutf(const char *fmt,...)
2862 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2867 #undef PerlIO_tmpfile
2869 PerlIO_tmpfile(void)
2871 /* I have no idea how portable mkstemp() is ... */
2872 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2874 FILE *stdio = tmpfile();
2877 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2883 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2884 int fd = mkstemp(SvPVX(sv));
2888 f = PerlIO_fdopen(fd,"w+");
2891 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2893 PerlLIO_unlink(SvPVX(sv));
2903 #endif /* USE_SFIO */
2904 #endif /* PERLIO_IS_STDIO */
2906 /*======================================================================================*/
2907 /* Now some functions in terms of above which may be needed even if
2908 we are not in true PerlIO mode
2912 #undef PerlIO_setpos
2914 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2916 return PerlIO_seek(f,*pos,0);
2919 #ifndef PERLIO_IS_STDIO
2920 #undef PerlIO_setpos
2922 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2924 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2925 return fsetpos64(f, pos);
2927 return fsetpos(f, pos);
2934 #undef PerlIO_getpos
2936 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2938 *pos = PerlIO_tell(f);
2939 return *pos == -1 ? -1 : 0;
2942 #ifndef PERLIO_IS_STDIO
2943 #undef PerlIO_getpos
2945 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2947 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2948 return fgetpos64(f, pos);
2950 return fgetpos(f, pos);
2956 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2959 vprintf(char *pat, char *args)
2961 _doprnt(pat, args, stdout);
2962 return 0; /* wrong, but perl doesn't use the return value */
2966 vfprintf(FILE *fd, char *pat, char *args)
2968 _doprnt(pat, args, fd);
2969 return 0; /* wrong, but perl doesn't use the return value */
2974 #ifndef PerlIO_vsprintf
2976 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2978 int val = vsprintf(s, fmt, ap);
2981 if (strlen(s) >= (STRLEN)n)
2984 (void)PerlIO_puts(Perl_error_log,
2985 "panic: sprintf overflow - memory corrupted!\n");
2993 #ifndef PerlIO_sprintf
2995 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3000 result = PerlIO_vsprintf(s, n, fmt, ap);
3006 #endif /* !PERL_IMPLICIT_SYS */