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 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
47 /* This used to be contents of do_binmode in doio.c */
49 # if defined(atarist) || defined(__MINT__)
50 if (!PerlIO_flush(fp)) {
52 ((FILE*)fp)->_flag |= _IOBIN;
54 ((FILE*)fp)->_flag &= ~ _IOBIN;
59 if (PerlLIO_setmode(PerlIO_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
69 ((FILE*)fp)->flags |= _F_BIN;
71 ((FILE*)fp)->flags &= ~ _F_BIN;
79 # if defined(USEMYBINMODE)
80 if (my_binmode(fp, iotype, mode) != FALSE)
95 #if !defined(PERL_IMPLICIT_SYS)
97 #ifdef PERLIO_IS_STDIO
102 /* Does nothing (yet) except force this file to be included
103 in perl binary. That allows this file to force inclusion
104 of other functions that may be required by loadable
105 extensions e.g. for FileHandle::tmpfile
109 #undef PerlIO_tmpfile
116 #else /* PERLIO_IS_STDIO */
123 /* This section is just to make sure these functions
124 get pulled in from libsfio.a
127 #undef PerlIO_tmpfile
137 /* Force this file to be included in perl binary. Which allows
138 * this file to force inclusion of other functions that may be
139 * required by loadable extensions e.g. for FileHandle::tmpfile
143 * sfio does its own 'autoflush' on stdout in common cases.
144 * Flush results in a lot of lseek()s to regular files and
145 * lot of small writes to pipes.
147 sfset(sfstdout,SF_SHARE,0);
151 /*======================================================================================*/
152 /* Implement all the PerlIO interface ourselves.
157 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
162 #include <sys/mman.h>
167 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
170 PerlIO_debug(const char *fmt,...)
177 char *s = PerlEnv_getenv("PERLIO_DEBUG");
179 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
186 SV *sv = newSVpvn("",0);
189 s = CopFILE(PL_curcop);
192 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
193 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
196 PerlLIO_write(dbg,s,len);
202 /*--------------------------------------------------------------------------------------*/
204 /* Inner level routines */
206 /* Table of pointers to the PerlIO structs (malloc'ed) */
207 PerlIO *_perlio = NULL;
208 #define PERLIO_TABLE_SIZE 64
211 PerlIO_allocate(void)
213 /* Find a free slot in the table, allocating new table as necessary */
214 PerlIO **last = &_perlio;
219 last = (PerlIO **)(f);
220 for (i=1; i < PERLIO_TABLE_SIZE; i++)
228 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
236 PerlIO_cleantable(PerlIO **tablep)
238 PerlIO *table = *tablep;
242 PerlIO_cleantable((PerlIO **) &(table[0]));
243 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
262 PerlIO_cleantable(&_perlio);
266 PerlIO_pop(PerlIO *f)
271 (*l->tab->Popped)(f);
277 /*--------------------------------------------------------------------------------------*/
278 /* XS Interface for perl code */
284 char *s = GvNAME(gv);
285 STRLEN l = GvNAMELEN(gv);
286 PerlIO_debug("%.*s\n",(int) l,s);
290 XS(XS_perlio_unimport)
294 char *s = GvNAME(gv);
295 STRLEN l = GvNAMELEN(gv);
296 PerlIO_debug("%.*s\n",(int) l,s);
301 PerlIO_find_layer(const char *name, STRLEN len)
308 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
309 if (svp && (sv = *svp) && SvROK(sv))
316 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
320 IO *io = GvIOn((GV *)SvRV(sv));
321 PerlIO *ifp = IoIFP(io);
322 PerlIO *ofp = IoOFP(io);
323 AV *av = (AV *) mg->mg_obj;
324 Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
330 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
334 IO *io = GvIOn((GV *)SvRV(sv));
335 PerlIO *ifp = IoIFP(io);
336 PerlIO *ofp = IoOFP(io);
337 AV *av = (AV *) mg->mg_obj;
338 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
344 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
346 Perl_warn(aTHX_ "clear %_",sv);
351 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
353 Perl_warn(aTHX_ "free %_",sv);
357 MGVTBL perlio_vtab = {
365 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
368 SV *sv = SvRV(ST(1));
373 sv_magic(sv, (SV *)av, '~', NULL, 0);
375 mg = mg_find(sv,'~');
376 mg->mg_virtual = &perlio_vtab;
378 Perl_warn(aTHX_ "attrib %_",sv);
379 for (i=2; i < items; i++)
382 const char *name = SvPV(ST(i),len);
383 SV *layer = PerlIO_find_layer(name,len);
386 av_push(av,SvREFCNT_inc(layer));
399 PerlIO_define_layer(PerlIO_funcs *tab)
402 HV *stash = gv_stashpv("perlio::Layer", TRUE);
403 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
404 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
408 PerlIO_default_layer(I32 n)
413 PerlIO_funcs *tab = &PerlIO_stdio;
415 if (!PerlIO_layer_hv)
417 const char *s = PerlEnv_getenv("PERLIO");
418 newXS("perlio::import",XS_perlio_import,__FILE__);
419 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
421 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
423 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
424 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
425 PerlIO_define_layer(&PerlIO_unix);
426 PerlIO_define_layer(&PerlIO_perlio);
427 PerlIO_define_layer(&PerlIO_stdio);
428 PerlIO_define_layer(&PerlIO_crlf);
430 PerlIO_define_layer(&PerlIO_mmap);
432 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
437 while (*s && isSPACE((unsigned char)*s))
443 while (*e && !isSPACE((unsigned char)*e))
447 layer = PerlIO_find_layer(s,e-s);
450 PerlIO_debug("Pushing %.*s\n",(e-s),s);
451 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
454 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
460 len = av_len(PerlIO_layer_av);
463 if (PerlIO_stdio.Set_ptrcnt)
465 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
469 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
471 len = av_len(PerlIO_layer_av);
475 svp = av_fetch(PerlIO_layer_av,n,0);
476 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
478 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
480 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
484 #define PerlIO_default_top() PerlIO_default_layer(-1)
485 #define PerlIO_default_btm() PerlIO_default_layer(0)
493 PerlIO_fdopen(0,"Ir");
494 PerlIO_fdopen(1,"Iw");
495 PerlIO_fdopen(2,"Iw");
500 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
503 Newc('L',l,tab->size,char,PerlIOl);
506 Zero(l,tab->size,char);
510 if ((*l->tab->Pushed)(f,mode) != 0)
520 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
524 const char *s = names;
534 while (*e && *e != ':' && !isSPACE(*e))
538 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
540 /* Pop back to bottom layer */
544 while (PerlIONext(f))
552 SV *layer = PerlIO_find_layer(s,e-s);
555 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
558 PerlIO *new = PerlIO_push(f,tab,mode);
564 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
576 /*--------------------------------------------------------------------------------------*/
577 /* Given the abstraction above the public API functions */
580 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
582 if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
588 if (PerlIOBase(top)->tab == &PerlIO_crlf)
594 top = PerlIONext(top);
597 return PerlIO_apply_layers(aTHX_ fp, NULL, names) == 0 ? TRUE : FALSE;
602 PerlIO_close(PerlIO *f)
604 int code = (*PerlIOBase(f)->tab->Close)(f);
614 PerlIO_fileno(PerlIO *f)
616 return (*PerlIOBase(f)->tab->Fileno)(f);
623 PerlIO_fdopen(int fd, const char *mode)
625 PerlIO_funcs *tab = PerlIO_default_top();
628 return (*tab->Fdopen)(tab,fd,mode);
633 PerlIO_open(const char *path, const char *mode)
635 PerlIO_funcs *tab = PerlIO_default_top();
638 return (*tab->Open)(tab,path,mode);
643 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
648 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
650 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
656 return PerlIO_open(path,mode);
661 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
663 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
668 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
670 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
675 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
677 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
682 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
684 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
689 PerlIO_tell(PerlIO *f)
691 return (*PerlIOBase(f)->tab->Tell)(f);
696 PerlIO_flush(PerlIO *f)
700 return (*PerlIOBase(f)->tab->Flush)(f);
704 PerlIO **table = &_perlio;
709 table = (PerlIO **)(f++);
710 for (i=1; i < PERLIO_TABLE_SIZE; i++)
712 if (*f && PerlIO_flush(f) != 0)
723 PerlIO_fill(PerlIO *f)
725 return (*PerlIOBase(f)->tab->Fill)(f);
730 PerlIO_isutf8(PerlIO *f)
732 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
737 PerlIO_eof(PerlIO *f)
739 return (*PerlIOBase(f)->tab->Eof)(f);
744 PerlIO_error(PerlIO *f)
746 return (*PerlIOBase(f)->tab->Error)(f);
749 #undef PerlIO_clearerr
751 PerlIO_clearerr(PerlIO *f)
753 (*PerlIOBase(f)->tab->Clearerr)(f);
756 #undef PerlIO_setlinebuf
758 PerlIO_setlinebuf(PerlIO *f)
760 (*PerlIOBase(f)->tab->Setlinebuf)(f);
763 #undef PerlIO_has_base
765 PerlIO_has_base(PerlIO *f)
769 return (PerlIOBase(f)->tab->Get_base != NULL);
774 #undef PerlIO_fast_gets
776 PerlIO_fast_gets(PerlIO *f)
780 PerlIOl *l = PerlIOBase(f);
781 return (l->tab->Set_ptrcnt != NULL);
786 #undef PerlIO_has_cntptr
788 PerlIO_has_cntptr(PerlIO *f)
792 PerlIO_funcs *tab = PerlIOBase(f)->tab;
793 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
798 #undef PerlIO_canset_cnt
800 PerlIO_canset_cnt(PerlIO *f)
804 PerlIOl *l = PerlIOBase(f);
805 return (l->tab->Set_ptrcnt != NULL);
810 #undef PerlIO_get_base
812 PerlIO_get_base(PerlIO *f)
814 return (*PerlIOBase(f)->tab->Get_base)(f);
817 #undef PerlIO_get_bufsiz
819 PerlIO_get_bufsiz(PerlIO *f)
821 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
824 #undef PerlIO_get_ptr
826 PerlIO_get_ptr(PerlIO *f)
828 return (*PerlIOBase(f)->tab->Get_ptr)(f);
831 #undef PerlIO_get_cnt
833 PerlIO_get_cnt(PerlIO *f)
835 return (*PerlIOBase(f)->tab->Get_cnt)(f);
838 #undef PerlIO_set_cnt
840 PerlIO_set_cnt(PerlIO *f,int cnt)
842 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
845 #undef PerlIO_set_ptrcnt
847 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
849 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
852 /*--------------------------------------------------------------------------------------*/
853 /* "Methods" of the "base class" */
856 PerlIOBase_fileno(PerlIO *f)
858 return PerlIO_fileno(PerlIONext(f));
862 PerlIOBase_pushed(PerlIO *f, const char *mode)
864 PerlIOl *l = PerlIOBase(f);
865 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
866 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
872 l->flags = PERLIO_F_CANREAD;
875 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
878 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
889 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
892 l->flags |= PERLIO_F_BINARY;
904 l->flags |= l->next->flags &
905 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
906 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
913 PerlIOBase_popped(PerlIO *f)
919 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
921 Off_t old = PerlIO_tell(f);
922 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
924 Off_t new = PerlIO_tell(f);
931 PerlIOBase_noop_ok(PerlIO *f)
937 PerlIOBase_noop_fail(PerlIO *f)
943 PerlIOBase_close(PerlIO *f)
946 if (PerlIO_flush(f) != 0)
948 if (PerlIO_close(PerlIONext(f)) != 0)
950 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
955 PerlIOBase_eof(PerlIO *f)
959 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
965 PerlIOBase_error(PerlIO *f)
969 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
975 PerlIOBase_clearerr(PerlIO *f)
979 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
984 PerlIOBase_setlinebuf(PerlIO *f)
989 /*--------------------------------------------------------------------------------------*/
990 /* Bottom-most level for UNIX-like case */
994 struct _PerlIO base; /* The generic part */
995 int fd; /* UNIX like file descriptor */
996 int oflags; /* open/fcntl flags */
1000 PerlIOUnix_oflags(const char *mode)
1015 oflags = O_CREAT|O_TRUNC;
1026 oflags = O_CREAT|O_APPEND;
1041 /* Always open in binary mode */
1043 if (*mode || oflags == -1)
1052 PerlIOUnix_fileno(PerlIO *f)
1054 return PerlIOSelf(f,PerlIOUnix)->fd;
1058 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1065 int oflags = PerlIOUnix_oflags(mode);
1068 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1071 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1078 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1081 int oflags = PerlIOUnix_oflags(mode);
1084 int fd = PerlLIO_open3(path,oflags,0666);
1087 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1090 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1097 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1099 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1100 int oflags = PerlIOUnix_oflags(mode);
1101 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1102 (*PerlIOBase(f)->tab->Close)(f);
1105 int fd = PerlLIO_open3(path,oflags,0666);
1110 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1118 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1120 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1121 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1125 SSize_t len = PerlLIO_read(fd,vbuf,count);
1126 if (len >= 0 || errno != EINTR)
1129 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1130 else if (len == 0 && count != 0)
1131 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1138 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1140 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1143 SSize_t len = PerlLIO_write(fd,vbuf,count);
1144 if (len >= 0 || errno != EINTR)
1147 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1154 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1156 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1157 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1158 return (new == (Off_t) -1) ? -1 : 0;
1162 PerlIOUnix_tell(PerlIO *f)
1164 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1168 PerlIOUnix_close(PerlIO *f)
1170 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1172 while (PerlLIO_close(fd) != 0)
1182 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1187 PerlIO_funcs PerlIO_unix = {
1203 PerlIOBase_noop_ok, /* flush */
1204 PerlIOBase_noop_fail, /* fill */
1207 PerlIOBase_clearerr,
1208 PerlIOBase_setlinebuf,
1209 NULL, /* get_base */
1210 NULL, /* get_bufsiz */
1213 NULL, /* set_ptrcnt */
1216 /*--------------------------------------------------------------------------------------*/
1217 /* stdio as a layer */
1221 struct _PerlIO base;
1222 FILE * stdio; /* The stream */
1226 PerlIOStdio_fileno(PerlIO *f)
1228 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1233 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1261 stdio = fdopen(fd,mode);
1264 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1271 #undef PerlIO_importFILE
1273 PerlIO_importFILE(FILE *stdio, int fl)
1278 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1285 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1288 FILE *stdio = fopen(path,mode);
1291 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1298 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1300 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1301 FILE *stdio = freopen(path,mode,s->stdio);
1309 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1311 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1315 STDCHAR *buf = (STDCHAR *) vbuf;
1316 /* Perl is expecting PerlIO_getc() to fill the buffer
1317 * Linux's stdio does not do that for fread()
1327 got = fread(vbuf,1,count,s);
1332 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1334 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1335 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1339 int ch = *buf-- & 0xff;
1340 if (ungetc(ch,s) != ch)
1349 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1351 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1355 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1357 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1358 return fseek(stdio,offset,whence);
1362 PerlIOStdio_tell(PerlIO *f)
1364 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1365 return ftell(stdio);
1369 PerlIOStdio_close(PerlIO *f)
1371 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1372 return fclose(stdio);
1376 PerlIOStdio_flush(PerlIO *f)
1378 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1379 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1381 return fflush(stdio);
1386 /* FIXME: This discards ungetc() and pre-read stuff which is
1387 not right if this is just a "sync" from a layer above
1388 Suspect right design is to do _this_ but not have layer above
1389 flush this layer read-to-read
1391 /* Not writeable - sync by attempting a seek */
1393 if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1401 PerlIOStdio_fill(PerlIO *f)
1403 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1405 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1406 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1408 if (fflush(stdio) != 0)
1412 if (c == EOF || ungetc(c,stdio) != c)
1418 PerlIOStdio_eof(PerlIO *f)
1420 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1424 PerlIOStdio_error(PerlIO *f)
1426 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1430 PerlIOStdio_clearerr(PerlIO *f)
1432 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1436 PerlIOStdio_setlinebuf(PerlIO *f)
1438 #ifdef HAS_SETLINEBUF
1439 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1441 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1447 PerlIOStdio_get_base(PerlIO *f)
1449 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1450 return FILE_base(stdio);
1454 PerlIOStdio_get_bufsiz(PerlIO *f)
1456 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1457 return FILE_bufsiz(stdio);
1461 #ifdef USE_STDIO_PTR
1463 PerlIOStdio_get_ptr(PerlIO *f)
1465 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1466 return FILE_ptr(stdio);
1470 PerlIOStdio_get_cnt(PerlIO *f)
1472 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1473 return FILE_cnt(stdio);
1477 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1479 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1482 #ifdef STDIO_PTR_LVALUE
1483 FILE_ptr(stdio) = ptr;
1484 #ifdef STDIO_PTR_LVAL_SETS_CNT
1485 if (FILE_cnt(stdio) != (cnt))
1488 assert(FILE_cnt(stdio) == (cnt));
1491 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1492 /* Setting ptr _does_ change cnt - we are done */
1495 #else /* STDIO_PTR_LVALUE */
1497 #endif /* STDIO_PTR_LVALUE */
1499 /* Now (or only) set cnt */
1500 #ifdef STDIO_CNT_LVALUE
1501 FILE_cnt(stdio) = cnt;
1502 #else /* STDIO_CNT_LVALUE */
1503 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1504 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1505 #else /* STDIO_PTR_LVAL_SETS_CNT */
1507 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1508 #endif /* STDIO_CNT_LVALUE */
1513 PerlIO_funcs PerlIO_stdio = {
1515 sizeof(PerlIOStdio),
1533 PerlIOStdio_clearerr,
1534 PerlIOStdio_setlinebuf,
1536 PerlIOStdio_get_base,
1537 PerlIOStdio_get_bufsiz,
1542 #ifdef USE_STDIO_PTR
1543 PerlIOStdio_get_ptr,
1544 PerlIOStdio_get_cnt,
1545 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1546 PerlIOStdio_set_ptrcnt
1547 #else /* STDIO_PTR_LVALUE */
1549 #endif /* STDIO_PTR_LVALUE */
1550 #else /* USE_STDIO_PTR */
1554 #endif /* USE_STDIO_PTR */
1557 #undef PerlIO_exportFILE
1559 PerlIO_exportFILE(PerlIO *f, int fl)
1562 /* Should really push stdio discipline when we have them */
1563 return fdopen(PerlIO_fileno(f),"r+");
1566 #undef PerlIO_findFILE
1568 PerlIO_findFILE(PerlIO *f)
1570 return PerlIO_exportFILE(f,0);
1573 #undef PerlIO_releaseFILE
1575 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1579 /*--------------------------------------------------------------------------------------*/
1580 /* perlio buffer layer */
1583 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1585 PerlIO_funcs *tab = PerlIO_default_btm();
1593 f = (*tab->Fdopen)(tab,fd,mode);
1596 /* Initial stderr is unbuffered */
1597 if (!init || fd != 2)
1599 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1600 b->posn = PerlIO_tell(PerlIONext(f));
1607 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1609 PerlIO_funcs *tab = PerlIO_default_btm();
1610 PerlIO *f = (*tab->Open)(tab,path,mode);
1613 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1614 b->posn = PerlIO_tell(PerlIONext(f));
1620 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1622 PerlIO *next = PerlIONext(f);
1623 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1625 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1628 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1629 b->posn = PerlIO_tell(PerlIONext(f));
1634 /* This "flush" is akin to sfio's sync in that it handles files in either
1638 PerlIOBuf_flush(PerlIO *f)
1640 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1642 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1644 /* write() the buffer */
1645 STDCHAR *p = b->buf;
1647 PerlIO *n = PerlIONext(f);
1650 count = PerlIO_write(n,p,b->ptr - p);
1655 else if (count < 0 || PerlIO_error(n))
1657 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1662 b->posn += (p - b->buf);
1664 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1666 /* Note position change */
1667 b->posn += (b->ptr - b->buf);
1668 if (b->ptr < b->end)
1670 /* We did not consume all of it */
1671 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1673 b->posn = PerlIO_tell(PerlIONext(f));
1677 b->ptr = b->end = b->buf;
1678 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1679 /* FIXME: Is this right for read case ? */
1680 if (PerlIO_flush(PerlIONext(f)) != 0)
1686 PerlIOBuf_fill(PerlIO *f)
1688 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1689 PerlIO *n = PerlIONext(f);
1691 /* FIXME: doing the down-stream flush is a bad idea if it causes
1692 pre-read data in stdio buffer to be discarded
1693 but this is too simplistic - as it skips _our_ hosekeeping
1694 and breaks tell tests.
1695 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1699 if (PerlIO_flush(f) != 0)
1702 b->ptr = b->end = b->buf;
1703 if (PerlIO_fast_gets(n))
1705 /* Layer below is also buffered
1706 * We do _NOT_ want to call its ->Read() because that will loop
1707 * till it gets what we asked for which may hang on a pipe etc.
1708 * Instead take anything it has to hand, or ask it to fill _once_.
1710 avail = PerlIO_get_cnt(n);
1713 avail = PerlIO_fill(n);
1715 avail = PerlIO_get_cnt(n);
1718 if (!PerlIO_error(n) && PerlIO_eof(n))
1724 STDCHAR *ptr = PerlIO_get_ptr(n);
1725 SSize_t cnt = avail;
1726 if (avail > b->bufsiz)
1728 Copy(ptr,b->buf,avail,STDCHAR);
1729 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1734 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1739 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1741 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1744 b->end = b->buf+avail;
1745 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1750 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1752 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1753 STDCHAR *buf = (STDCHAR *) vbuf;
1758 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1762 SSize_t avail = PerlIO_get_cnt(f);
1763 SSize_t take = (count < avail) ? count : avail;
1766 STDCHAR *ptr = PerlIO_get_ptr(f);
1767 Copy(ptr,buf,take,STDCHAR);
1768 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1772 if (count > 0 && avail <= 0)
1774 if (PerlIO_fill(f) != 0)
1778 return (buf - (STDCHAR *) vbuf);
1784 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1786 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1787 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1790 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1796 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1798 avail = (b->ptr - b->buf);
1799 if (avail > (SSize_t) count)
1806 if (avail > (SSize_t) count)
1808 b->end = b->ptr + avail;
1815 Copy(buf,b->ptr,avail,STDCHAR);
1819 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1826 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1828 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1829 const STDCHAR *buf = (const STDCHAR *) vbuf;
1833 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1837 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1838 if ((SSize_t) count < avail)
1840 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1841 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1861 Copy(buf,b->ptr,avail,STDCHAR);
1868 if (b->ptr >= (b->buf + b->bufsiz))
1875 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1877 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1878 int code = PerlIO_flush(f);
1881 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1882 code = PerlIO_seek(PerlIONext(f),offset,whence);
1885 b->posn = PerlIO_tell(PerlIONext(f));
1892 PerlIOBuf_tell(PerlIO *f)
1894 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1895 Off_t posn = b->posn;
1897 posn += (b->ptr - b->buf);
1902 PerlIOBuf_close(PerlIO *f)
1904 IV code = PerlIOBase_close(f);
1905 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1906 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1911 b->ptr = b->end = b->buf;
1912 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1917 PerlIOBuf_setlinebuf(PerlIO *f)
1921 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1926 PerlIOBuf_get_ptr(PerlIO *f)
1928 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1935 PerlIOBuf_get_cnt(PerlIO *f)
1937 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1940 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1941 return (b->end - b->ptr);
1946 PerlIOBuf_get_base(PerlIO *f)
1948 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1953 New('B',b->buf,b->bufsiz,STDCHAR);
1956 b->buf = (STDCHAR *)&b->oneword;
1957 b->bufsiz = sizeof(b->oneword);
1966 PerlIOBuf_bufsiz(PerlIO *f)
1968 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1971 return (b->end - b->buf);
1975 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1977 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1981 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1984 assert(PerlIO_get_cnt(f) == cnt);
1985 assert(b->ptr >= b->buf);
1987 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1990 PerlIO_funcs PerlIO_perlio = {
2010 PerlIOBase_clearerr,
2011 PerlIOBuf_setlinebuf,
2016 PerlIOBuf_set_ptrcnt,
2019 /*--------------------------------------------------------------------------------------*/
2020 /* crlf - translation
2021 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2022 to hand back a line at a time and keeping a record of which nl we "lied" about.
2023 On write translate "\n" to CR,LF
2028 PerlIOBuf base; /* PerlIOBuf stuff */
2029 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2033 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2035 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2036 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2037 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2039 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2050 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2052 b->end = b->ptr = b->buf + b->bufsiz;
2053 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2055 while (count > 0 && b->ptr > b->buf)
2060 if (b->ptr - 2 >= b->buf)
2085 PerlIOCrlf_get_cnt(PerlIO *f)
2087 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2090 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2092 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2095 STDCHAR *nl = b->ptr;
2097 while (nl < b->end && *nl != 0xd)
2099 if (nl < b->end && *nl == 0xd)
2111 /* Not CR,LF but just CR */
2118 /* Blast - found CR as last char in buffer */
2121 /* They may not care, defer work as long as possible */
2122 return (nl - b->ptr);
2128 b->ptr++; /* say we have read it as far as flush() is concerned */
2129 b->buf++; /* Leave space an front of buffer */
2130 b->bufsiz--; /* Buffer is thus smaller */
2131 code = PerlIO_fill(f); /* Fetch some more */
2132 b->bufsiz++; /* Restore size for next time */
2133 b->buf--; /* Point at space */
2134 b->ptr = nl = b->buf; /* Which is what we hand off */
2135 b->posn--; /* Buffer starts here */
2136 *nl = 0xd; /* Fill in the CR */
2138 goto test; /* fill() call worked */
2139 /* CR at EOF - just fall through */
2144 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2150 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2152 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2153 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2163 if (ptr > b->buf && ptr[-1] == 0xd)
2170 /* Test code - delete when it works ... */
2177 if (chk > b->buf && chk[-1] == 0xd)
2185 Perl_croak(aTHX_ "ptr wrong %p != %p nl=%p e=%p for %d",
2186 ptr, chk, c->nl, b->end, cnt);
2193 /* They have taken what we lied about */
2200 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2204 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2206 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2207 const STDCHAR *buf = (const STDCHAR *) vbuf;
2208 const STDCHAR *ebuf = buf+count;
2211 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2215 STDCHAR *eptr = b->buf+b->bufsiz;
2216 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2217 while (buf < ebuf && b->ptr < eptr)
2221 if ((b->ptr + 2) > eptr)
2223 /* Not room for both */
2229 *(b->ptr)++ = 0xd; /* CR */
2230 *(b->ptr)++ = 0xa; /* LF */
2232 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2251 return (buf - (STDCHAR *) vbuf);
2255 PerlIOCrlf_flush(PerlIO *f)
2257 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2263 return PerlIOBuf_flush(f);
2266 PerlIO_funcs PerlIO_crlf = {
2275 PerlIOBase_noop_ok, /* popped */
2276 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2277 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2278 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2286 PerlIOBase_clearerr,
2287 PerlIOBuf_setlinebuf,
2292 PerlIOCrlf_set_ptrcnt,
2296 /*--------------------------------------------------------------------------------------*/
2297 /* mmap as "buffer" layer */
2301 PerlIOBuf base; /* PerlIOBuf stuff */
2302 Mmap_t mptr; /* Mapped address */
2303 Size_t len; /* mapped length */
2304 STDCHAR *bbuf; /* malloced buffer if map fails */
2307 static size_t page_size = 0;
2310 PerlIOMmap_map(PerlIO *f)
2313 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2314 PerlIOBuf *b = &m->base;
2315 IV flags = PerlIOBase(f)->flags;
2319 if (flags & PERLIO_F_CANREAD)
2321 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2322 int fd = PerlIO_fileno(f);
2324 code = fstat(fd,&st);
2325 if (code == 0 && S_ISREG(st.st_mode))
2327 SSize_t len = st.st_size - b->posn;
2332 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2334 SETERRNO(0,SS$_NORMAL);
2335 # ifdef _SC_PAGESIZE
2336 page_size = sysconf(_SC_PAGESIZE);
2338 page_size = sysconf(_SC_PAGE_SIZE);
2340 if ((long)page_size < 0) {
2345 (void)SvUPGRADE(error, SVt_PV);
2346 msg = SvPVx(error, n_a);
2347 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2350 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2354 # ifdef HAS_GETPAGESIZE
2355 page_size = getpagesize();
2357 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2358 page_size = PAGESIZE; /* compiletime, bad */
2362 if ((IV)page_size <= 0)
2363 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2367 /* This is a hack - should never happen - open should have set it ! */
2368 b->posn = PerlIO_tell(PerlIONext(f));
2370 posn = (b->posn / page_size) * page_size;
2371 len = st.st_size - posn;
2372 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2373 if (m->mptr && m->mptr != (Mmap_t) -1)
2375 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2376 madvise(m->mptr, len, MADV_SEQUENTIAL);
2378 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2379 b->end = ((STDCHAR *)m->mptr) + len;
2380 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2391 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2393 b->ptr = b->end = b->ptr;
2402 PerlIOMmap_unmap(PerlIO *f)
2404 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2405 PerlIOBuf *b = &m->base;
2411 code = munmap(m->mptr, m->len);
2415 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2418 b->ptr = b->end = b->buf;
2419 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2425 PerlIOMmap_get_base(PerlIO *f)
2427 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2428 PerlIOBuf *b = &m->base;
2429 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2431 /* Already have a readbuffer in progress */
2436 /* We have a write buffer or flushed PerlIOBuf read buffer */
2437 m->bbuf = b->buf; /* save it in case we need it again */
2438 b->buf = NULL; /* Clear to trigger below */
2442 PerlIOMmap_map(f); /* Try and map it */
2445 /* Map did not work - recover PerlIOBuf buffer if we have one */
2449 b->ptr = b->end = b->buf;
2452 return PerlIOBuf_get_base(f);
2456 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2458 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2459 PerlIOBuf *b = &m->base;
2460 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2462 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2465 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2470 /* Loose the unwritable mapped buffer */
2472 /* If flush took the "buffer" see if we have one from before */
2473 if (!b->buf && m->bbuf)
2477 PerlIOBuf_get_base(f);
2481 return PerlIOBuf_unread(f,vbuf,count);
2485 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2487 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2488 PerlIOBuf *b = &m->base;
2489 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2491 /* No, or wrong sort of, buffer */
2494 if (PerlIOMmap_unmap(f) != 0)
2497 /* If unmap took the "buffer" see if we have one from before */
2498 if (!b->buf && m->bbuf)
2502 PerlIOBuf_get_base(f);
2506 return PerlIOBuf_write(f,vbuf,count);
2510 PerlIOMmap_flush(PerlIO *f)
2512 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2513 PerlIOBuf *b = &m->base;
2514 IV code = PerlIOBuf_flush(f);
2515 /* Now we are "synced" at PerlIOBuf level */
2520 /* Unmap the buffer */
2521 if (PerlIOMmap_unmap(f) != 0)
2526 /* We seem to have a PerlIOBuf buffer which was not mapped
2527 * remember it in case we need one later
2536 PerlIOMmap_fill(PerlIO *f)
2538 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2539 IV code = PerlIO_flush(f);
2540 if (code == 0 && !b->buf)
2542 code = PerlIOMmap_map(f);
2544 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2546 code = PerlIOBuf_fill(f);
2552 PerlIOMmap_close(PerlIO *f)
2554 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2555 PerlIOBuf *b = &m->base;
2556 IV code = PerlIO_flush(f);
2561 b->ptr = b->end = b->buf;
2563 if (PerlIOBuf_close(f) != 0)
2569 PerlIO_funcs PerlIO_mmap = {
2589 PerlIOBase_clearerr,
2590 PerlIOBuf_setlinebuf,
2591 PerlIOMmap_get_base,
2595 PerlIOBuf_set_ptrcnt,
2598 #endif /* HAS_MMAP */
2605 atexit(&PerlIO_cleanup);
2614 PerlIO_stdstreams();
2618 #undef PerlIO_stdout
2623 PerlIO_stdstreams();
2627 #undef PerlIO_stderr
2632 PerlIO_stdstreams();
2636 /*--------------------------------------------------------------------------------------*/
2638 #undef PerlIO_getname
2640 PerlIO_getname(PerlIO *f, char *buf)
2643 Perl_croak(aTHX_ "Don't know how to get file name");
2648 /*--------------------------------------------------------------------------------------*/
2649 /* Functions which can be called on any kind of PerlIO implemented
2655 PerlIO_getc(PerlIO *f)
2658 SSize_t count = PerlIO_read(f,buf,1);
2661 return (unsigned char) buf[0];
2666 #undef PerlIO_ungetc
2668 PerlIO_ungetc(PerlIO *f, int ch)
2673 if (PerlIO_unread(f,&buf,1) == 1)
2681 PerlIO_putc(PerlIO *f, int ch)
2684 return PerlIO_write(f,&buf,1);
2689 PerlIO_puts(PerlIO *f, const char *s)
2691 STRLEN len = strlen(s);
2692 return PerlIO_write(f,s,len);
2695 #undef PerlIO_rewind
2697 PerlIO_rewind(PerlIO *f)
2699 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2703 #undef PerlIO_vprintf
2705 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2708 SV *sv = newSVpvn("",0);
2713 Perl_va_copy(ap, apc);
2714 sv_vcatpvf(sv, fmt, &apc);
2716 sv_vcatpvf(sv, fmt, &ap);
2719 return PerlIO_write(f,s,len);
2722 #undef PerlIO_printf
2724 PerlIO_printf(PerlIO *f,const char *fmt,...)
2729 result = PerlIO_vprintf(f,fmt,ap);
2734 #undef PerlIO_stdoutf
2736 PerlIO_stdoutf(const char *fmt,...)
2741 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2746 #undef PerlIO_tmpfile
2748 PerlIO_tmpfile(void)
2750 /* I have no idea how portable mkstemp() is ... */
2751 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2753 FILE *stdio = tmpfile();
2756 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2762 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2763 int fd = mkstemp(SvPVX(sv));
2767 f = PerlIO_fdopen(fd,"w+");
2770 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2772 PerlLIO_unlink(SvPVX(sv));
2782 #endif /* USE_SFIO */
2783 #endif /* PERLIO_IS_STDIO */
2785 /*======================================================================================*/
2786 /* Now some functions in terms of above which may be needed even if
2787 we are not in true PerlIO mode
2791 #undef PerlIO_setpos
2793 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2795 return PerlIO_seek(f,*pos,0);
2798 #ifndef PERLIO_IS_STDIO
2799 #undef PerlIO_setpos
2801 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2803 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2804 return fsetpos64(f, pos);
2806 return fsetpos(f, pos);
2813 #undef PerlIO_getpos
2815 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2817 *pos = PerlIO_tell(f);
2818 return *pos == -1 ? -1 : 0;
2821 #ifndef PERLIO_IS_STDIO
2822 #undef PerlIO_getpos
2824 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2826 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2827 return fgetpos64(f, pos);
2829 return fgetpos(f, pos);
2835 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2838 vprintf(char *pat, char *args)
2840 _doprnt(pat, args, stdout);
2841 return 0; /* wrong, but perl doesn't use the return value */
2845 vfprintf(FILE *fd, char *pat, char *args)
2847 _doprnt(pat, args, fd);
2848 return 0; /* wrong, but perl doesn't use the return value */
2853 #ifndef PerlIO_vsprintf
2855 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2857 int val = vsprintf(s, fmt, ap);
2860 if (strlen(s) >= (STRLEN)n)
2863 (void)PerlIO_puts(Perl_error_log,
2864 "panic: sprintf overflow - memory corrupted!\n");
2872 #ifndef PerlIO_sprintf
2874 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2879 result = PerlIO_vsprintf(s, n, fmt, ap);
2885 #endif /* !PERL_IMPLICIT_SYS */