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 %"SVf" %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 %"SVf" %p %p %p",sv,io,ifp,ofp);
348 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
350 Perl_warn(aTHX_ "clear %"SVf,sv);
355 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
357 Perl_warn(aTHX_ "free %"SVf,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 %"SVf,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=%08"UVxf" (%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
1679 /* do something about failing setmode()? --jhi */
1680 PerlLIO_setmode(fd, O_BINARY);
1682 f = (*tab->Fdopen)(tab,fd,mode);
1685 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1686 b->posn = PerlIO_tell(PerlIONext(f));
1687 if (init && fd == 2)
1689 /* Initial stderr is unbuffered */
1690 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1692 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1693 self->name,f,fd,mode,PerlIOBase(f)->flags);
1699 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1701 PerlIO_funcs *tab = PerlIO_default_btm();
1702 PerlIO *f = (*tab->Open)(tab,path,mode);
1705 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1706 b->posn = PerlIO_tell(PerlIONext(f));
1712 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1714 PerlIO *next = PerlIONext(f);
1715 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1717 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1720 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1721 b->posn = PerlIO_tell(PerlIONext(f));
1726 /* This "flush" is akin to sfio's sync in that it handles files in either
1730 PerlIOBuf_flush(PerlIO *f)
1732 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1734 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1736 /* write() the buffer */
1737 STDCHAR *p = b->buf;
1739 PerlIO *n = PerlIONext(f);
1742 count = PerlIO_write(n,p,b->ptr - p);
1747 else if (count < 0 || PerlIO_error(n))
1749 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1754 b->posn += (p - b->buf);
1756 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1758 /* Note position change */
1759 b->posn += (b->ptr - b->buf);
1760 if (b->ptr < b->end)
1762 /* We did not consume all of it */
1763 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1765 b->posn = PerlIO_tell(PerlIONext(f));
1769 b->ptr = b->end = b->buf;
1770 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1771 /* FIXME: Is this right for read case ? */
1772 if (PerlIO_flush(PerlIONext(f)) != 0)
1778 PerlIOBuf_fill(PerlIO *f)
1780 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1781 PerlIO *n = PerlIONext(f);
1783 /* FIXME: doing the down-stream flush is a bad idea if it causes
1784 pre-read data in stdio buffer to be discarded
1785 but this is too simplistic - as it skips _our_ hosekeeping
1786 and breaks tell tests.
1787 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1791 if (PerlIO_flush(f) != 0)
1794 b->ptr = b->end = b->buf;
1795 if (PerlIO_fast_gets(n))
1797 /* Layer below is also buffered
1798 * We do _NOT_ want to call its ->Read() because that will loop
1799 * till it gets what we asked for which may hang on a pipe etc.
1800 * Instead take anything it has to hand, or ask it to fill _once_.
1802 avail = PerlIO_get_cnt(n);
1805 avail = PerlIO_fill(n);
1807 avail = PerlIO_get_cnt(n);
1810 if (!PerlIO_error(n) && PerlIO_eof(n))
1816 STDCHAR *ptr = PerlIO_get_ptr(n);
1817 SSize_t cnt = avail;
1818 if (avail > b->bufsiz)
1820 Copy(ptr,b->buf,avail,STDCHAR);
1821 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1826 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1831 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1833 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1836 b->end = b->buf+avail;
1837 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1842 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1844 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1845 STDCHAR *buf = (STDCHAR *) vbuf;
1850 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1854 SSize_t avail = PerlIO_get_cnt(f);
1855 SSize_t take = (count < avail) ? count : avail;
1858 STDCHAR *ptr = PerlIO_get_ptr(f);
1859 Copy(ptr,buf,take,STDCHAR);
1860 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1864 if (count > 0 && avail <= 0)
1866 if (PerlIO_fill(f) != 0)
1870 return (buf - (STDCHAR *) vbuf);
1876 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1878 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1879 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1882 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1888 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1890 avail = (b->ptr - b->buf);
1891 if (avail > (SSize_t) count)
1898 if (avail > (SSize_t) count)
1900 b->end = b->ptr + avail;
1907 Copy(buf,b->ptr,avail,STDCHAR);
1911 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1918 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1920 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1921 const STDCHAR *buf = (const STDCHAR *) vbuf;
1925 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1929 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1930 if ((SSize_t) count < avail)
1932 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1933 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1953 Copy(buf,b->ptr,avail,STDCHAR);
1960 if (b->ptr >= (b->buf + b->bufsiz))
1963 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
1969 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1971 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1972 int code = PerlIO_flush(f);
1975 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1976 code = PerlIO_seek(PerlIONext(f),offset,whence);
1979 b->posn = PerlIO_tell(PerlIONext(f));
1986 PerlIOBuf_tell(PerlIO *f)
1988 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1989 Off_t posn = b->posn;
1991 posn += (b->ptr - b->buf);
1996 PerlIOBuf_close(PerlIO *f)
1998 IV code = PerlIOBase_close(f);
1999 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2000 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2005 b->ptr = b->end = b->buf;
2006 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2011 PerlIOBuf_setlinebuf(PerlIO *f)
2015 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2020 PerlIOBuf_get_ptr(PerlIO *f)
2022 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2029 PerlIOBuf_get_cnt(PerlIO *f)
2031 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2034 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2035 return (b->end - b->ptr);
2040 PerlIOBuf_get_base(PerlIO *f)
2042 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2047 New('B',b->buf,b->bufsiz,STDCHAR);
2050 b->buf = (STDCHAR *)&b->oneword;
2051 b->bufsiz = sizeof(b->oneword);
2060 PerlIOBuf_bufsiz(PerlIO *f)
2062 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2065 return (b->end - b->buf);
2069 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2071 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2075 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2078 assert(PerlIO_get_cnt(f) == cnt);
2079 assert(b->ptr >= b->buf);
2081 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2084 PerlIO_funcs PerlIO_perlio = {
2104 PerlIOBase_clearerr,
2105 PerlIOBuf_setlinebuf,
2110 PerlIOBuf_set_ptrcnt,
2113 /*--------------------------------------------------------------------------------------*/
2114 /* crlf - translation
2115 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2116 to hand back a line at a time and keeping a record of which nl we "lied" about.
2117 On write translate "\n" to CR,LF
2122 PerlIOBuf base; /* PerlIOBuf stuff */
2123 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2127 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2130 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2131 code = PerlIOBase_pushed(f,mode);
2132 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2133 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2134 PerlIOBase(f)->flags);
2140 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2142 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2148 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2149 return PerlIOBuf_unread(f,vbuf,count);
2152 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2153 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2155 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2161 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2163 b->end = b->ptr = b->buf + b->bufsiz;
2164 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2166 while (count > 0 && b->ptr > b->buf)
2171 if (b->ptr - 2 >= b->buf)
2197 PerlIOCrlf_get_cnt(PerlIO *f)
2199 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2202 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2204 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2205 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2207 STDCHAR *nl = b->ptr;
2209 while (nl < b->end && *nl != 0xd)
2211 if (nl < b->end && *nl == 0xd)
2223 /* Not CR,LF but just CR */
2230 /* Blast - found CR as last char in buffer */
2233 /* They may not care, defer work as long as possible */
2234 return (nl - b->ptr);
2240 b->ptr++; /* say we have read it as far as flush() is concerned */
2241 b->buf++; /* Leave space an front of buffer */
2242 b->bufsiz--; /* Buffer is thus smaller */
2243 code = PerlIO_fill(f); /* Fetch some more */
2244 b->bufsiz++; /* Restore size for next time */
2245 b->buf--; /* Point at space */
2246 b->ptr = nl = b->buf; /* Which is what we hand off */
2247 b->posn--; /* Buffer starts here */
2248 *nl = 0xd; /* Fill in the CR */
2250 goto test; /* fill() call worked */
2251 /* CR at EOF - just fall through */
2256 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2262 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2264 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2265 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2266 IV flags = PerlIOBase(f)->flags;
2276 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2283 /* Test code - delete when it works ... */
2290 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2298 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2299 ptr, chk, flags, c->nl, b->end, cnt);
2306 /* They have taken what we lied about */
2313 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2317 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2319 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2320 return PerlIOBuf_write(f,vbuf,count);
2323 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2324 const STDCHAR *buf = (const STDCHAR *) vbuf;
2325 const STDCHAR *ebuf = buf+count;
2328 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2332 STDCHAR *eptr = b->buf+b->bufsiz;
2333 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2334 while (buf < ebuf && b->ptr < eptr)
2338 if ((b->ptr + 2) > eptr)
2340 /* Not room for both */
2346 *(b->ptr)++ = 0xd; /* CR */
2347 *(b->ptr)++ = 0xa; /* LF */
2349 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2368 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2370 return (buf - (STDCHAR *) vbuf);
2375 PerlIOCrlf_flush(PerlIO *f)
2377 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2383 return PerlIOBuf_flush(f);
2386 PerlIO_funcs PerlIO_crlf = {
2389 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2395 PerlIOBase_noop_ok, /* popped */
2396 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2397 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2398 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2406 PerlIOBase_clearerr,
2407 PerlIOBuf_setlinebuf,
2412 PerlIOCrlf_set_ptrcnt,
2416 /*--------------------------------------------------------------------------------------*/
2417 /* mmap as "buffer" layer */
2421 PerlIOBuf base; /* PerlIOBuf stuff */
2422 Mmap_t mptr; /* Mapped address */
2423 Size_t len; /* mapped length */
2424 STDCHAR *bbuf; /* malloced buffer if map fails */
2427 static size_t page_size = 0;
2430 PerlIOMmap_map(PerlIO *f)
2433 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2434 PerlIOBuf *b = &m->base;
2435 IV flags = PerlIOBase(f)->flags;
2439 if (flags & PERLIO_F_CANREAD)
2441 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2442 int fd = PerlIO_fileno(f);
2444 code = fstat(fd,&st);
2445 if (code == 0 && S_ISREG(st.st_mode))
2447 SSize_t len = st.st_size - b->posn;
2452 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2454 SETERRNO(0,SS$_NORMAL);
2455 # ifdef _SC_PAGESIZE
2456 page_size = sysconf(_SC_PAGESIZE);
2458 page_size = sysconf(_SC_PAGE_SIZE);
2460 if ((long)page_size < 0) {
2465 (void)SvUPGRADE(error, SVt_PV);
2466 msg = SvPVx(error, n_a);
2467 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2470 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2474 # ifdef HAS_GETPAGESIZE
2475 page_size = getpagesize();
2477 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2478 page_size = PAGESIZE; /* compiletime, bad */
2482 if ((IV)page_size <= 0)
2483 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2487 /* This is a hack - should never happen - open should have set it ! */
2488 b->posn = PerlIO_tell(PerlIONext(f));
2490 posn = (b->posn / page_size) * page_size;
2491 len = st.st_size - posn;
2492 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2493 if (m->mptr && m->mptr != (Mmap_t) -1)
2495 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2496 madvise(m->mptr, len, MADV_SEQUENTIAL);
2498 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2499 b->end = ((STDCHAR *)m->mptr) + len;
2500 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2511 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2513 b->ptr = b->end = b->ptr;
2522 PerlIOMmap_unmap(PerlIO *f)
2524 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2525 PerlIOBuf *b = &m->base;
2531 code = munmap(m->mptr, m->len);
2535 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2538 b->ptr = b->end = b->buf;
2539 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2545 PerlIOMmap_get_base(PerlIO *f)
2547 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2548 PerlIOBuf *b = &m->base;
2549 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2551 /* Already have a readbuffer in progress */
2556 /* We have a write buffer or flushed PerlIOBuf read buffer */
2557 m->bbuf = b->buf; /* save it in case we need it again */
2558 b->buf = NULL; /* Clear to trigger below */
2562 PerlIOMmap_map(f); /* Try and map it */
2565 /* Map did not work - recover PerlIOBuf buffer if we have one */
2569 b->ptr = b->end = b->buf;
2572 return PerlIOBuf_get_base(f);
2576 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2578 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2579 PerlIOBuf *b = &m->base;
2580 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2582 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2585 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2590 /* Loose the unwritable mapped buffer */
2592 /* If flush took the "buffer" see if we have one from before */
2593 if (!b->buf && m->bbuf)
2597 PerlIOBuf_get_base(f);
2601 return PerlIOBuf_unread(f,vbuf,count);
2605 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2607 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2608 PerlIOBuf *b = &m->base;
2609 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2611 /* No, or wrong sort of, buffer */
2614 if (PerlIOMmap_unmap(f) != 0)
2617 /* If unmap took the "buffer" see if we have one from before */
2618 if (!b->buf && m->bbuf)
2622 PerlIOBuf_get_base(f);
2626 return PerlIOBuf_write(f,vbuf,count);
2630 PerlIOMmap_flush(PerlIO *f)
2632 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2633 PerlIOBuf *b = &m->base;
2634 IV code = PerlIOBuf_flush(f);
2635 /* Now we are "synced" at PerlIOBuf level */
2640 /* Unmap the buffer */
2641 if (PerlIOMmap_unmap(f) != 0)
2646 /* We seem to have a PerlIOBuf buffer which was not mapped
2647 * remember it in case we need one later
2656 PerlIOMmap_fill(PerlIO *f)
2658 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2659 IV code = PerlIO_flush(f);
2660 if (code == 0 && !b->buf)
2662 code = PerlIOMmap_map(f);
2664 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2666 code = PerlIOBuf_fill(f);
2672 PerlIOMmap_close(PerlIO *f)
2674 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2675 PerlIOBuf *b = &m->base;
2676 IV code = PerlIO_flush(f);
2681 b->ptr = b->end = b->buf;
2683 if (PerlIOBuf_close(f) != 0)
2689 PerlIO_funcs PerlIO_mmap = {
2709 PerlIOBase_clearerr,
2710 PerlIOBuf_setlinebuf,
2711 PerlIOMmap_get_base,
2715 PerlIOBuf_set_ptrcnt,
2718 #endif /* HAS_MMAP */
2725 atexit(&PerlIO_cleanup);
2734 PerlIO_stdstreams();
2738 #undef PerlIO_stdout
2743 PerlIO_stdstreams();
2747 #undef PerlIO_stderr
2752 PerlIO_stdstreams();
2756 /*--------------------------------------------------------------------------------------*/
2758 #undef PerlIO_getname
2760 PerlIO_getname(PerlIO *f, char *buf)
2763 Perl_croak(aTHX_ "Don't know how to get file name");
2768 /*--------------------------------------------------------------------------------------*/
2769 /* Functions which can be called on any kind of PerlIO implemented
2775 PerlIO_getc(PerlIO *f)
2778 SSize_t count = PerlIO_read(f,buf,1);
2781 return (unsigned char) buf[0];
2786 #undef PerlIO_ungetc
2788 PerlIO_ungetc(PerlIO *f, int ch)
2793 if (PerlIO_unread(f,&buf,1) == 1)
2801 PerlIO_putc(PerlIO *f, int ch)
2804 return PerlIO_write(f,&buf,1);
2809 PerlIO_puts(PerlIO *f, const char *s)
2811 STRLEN len = strlen(s);
2812 return PerlIO_write(f,s,len);
2815 #undef PerlIO_rewind
2817 PerlIO_rewind(PerlIO *f)
2819 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2823 #undef PerlIO_vprintf
2825 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2828 SV *sv = newSVpvn("",0);
2833 Perl_va_copy(ap, apc);
2834 sv_vcatpvf(sv, fmt, &apc);
2836 sv_vcatpvf(sv, fmt, &ap);
2839 return PerlIO_write(f,s,len);
2842 #undef PerlIO_printf
2844 PerlIO_printf(PerlIO *f,const char *fmt,...)
2849 result = PerlIO_vprintf(f,fmt,ap);
2854 #undef PerlIO_stdoutf
2856 PerlIO_stdoutf(const char *fmt,...)
2861 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2866 #undef PerlIO_tmpfile
2868 PerlIO_tmpfile(void)
2870 /* I have no idea how portable mkstemp() is ... */
2871 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2873 FILE *stdio = tmpfile();
2876 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2882 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2883 int fd = mkstemp(SvPVX(sv));
2887 f = PerlIO_fdopen(fd,"w+");
2890 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2892 PerlLIO_unlink(SvPVX(sv));
2902 #endif /* USE_SFIO */
2903 #endif /* PERLIO_IS_STDIO */
2905 /*======================================================================================*/
2906 /* Now some functions in terms of above which may be needed even if
2907 we are not in true PerlIO mode
2911 #undef PerlIO_setpos
2913 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2915 return PerlIO_seek(f,*pos,0);
2918 #ifndef PERLIO_IS_STDIO
2919 #undef PerlIO_setpos
2921 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2923 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2924 return fsetpos64(f, pos);
2926 return fsetpos(f, pos);
2933 #undef PerlIO_getpos
2935 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2937 *pos = PerlIO_tell(f);
2938 return *pos == -1 ? -1 : 0;
2941 #ifndef PERLIO_IS_STDIO
2942 #undef PerlIO_getpos
2944 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2946 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2947 return fgetpos64(f, pos);
2949 return fgetpos(f, pos);
2955 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2958 vprintf(char *pat, char *args)
2960 _doprnt(pat, args, stdout);
2961 return 0; /* wrong, but perl doesn't use the return value */
2965 vfprintf(FILE *fd, char *pat, char *args)
2967 _doprnt(pat, args, fd);
2968 return 0; /* wrong, but perl doesn't use the return value */
2973 #ifndef PerlIO_vsprintf
2975 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2977 int val = vsprintf(s, fmt, ap);
2980 if (strlen(s) >= (STRLEN)n)
2983 (void)PerlIO_puts(Perl_error_log,
2984 "panic: sprintf overflow - memory corrupted!\n");
2992 #ifndef PerlIO_sprintf
2994 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2999 result = PerlIO_vsprintf(s, n, fmt, ap);
3005 #endif /* !PERL_IMPLICIT_SYS */