3 * Copyright (c) 1996-2000, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in iperlsys.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
33 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
35 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
39 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
45 #if !defined(PERL_IMPLICIT_SYS)
47 #ifdef PERLIO_IS_STDIO
52 /* Does nothing (yet) except force this file to be included
53 in perl binary. That allows this file to force inclusion
54 of other functions that may be required by loadable
55 extensions e.g. for FileHandle::tmpfile
66 #else /* PERLIO_IS_STDIO */
73 /* This section is just to make sure these functions
74 get pulled in from libsfio.a
87 /* Force this file to be included in perl binary. Which allows
88 * this file to force inclusion of other functions that may be
89 * required by loadable extensions e.g. for FileHandle::tmpfile
93 * sfio does its own 'autoflush' on stdout in common cases.
94 * Flush results in a lot of lseek()s to regular files and
95 * lot of small writes to pipes.
97 sfset(sfstdout,SF_SHARE,0);
101 /*======================================================================================*/
102 /* Implement all the PerlIO interface ourselves.
107 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
112 #include <sys/mman.h>
117 void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2)));
120 PerlIO_debug(char *fmt,...)
125 char *s = PerlEnv_getenv("PERLIO_DEBUG");
127 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
135 SV *sv = newSVpvn("",0);
139 s = CopFILE(PL_curcop);
142 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
143 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
146 PerlLIO_write(dbg,s,len);
152 /*--------------------------------------------------------------------------------------*/
154 /* Inner level routines */
156 /* Table of pointers to the PerlIO structs (malloc'ed) */
157 PerlIO *_perlio = NULL;
158 #define PERLIO_TABLE_SIZE 64
161 PerlIO_allocate(void)
163 /* Find a free slot in the table, allocating new table as necessary */
164 PerlIO **last = &_perlio;
169 last = (PerlIO **)(f);
170 for (i=1; i < PERLIO_TABLE_SIZE; i++)
178 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
186 PerlIO_cleantable(PerlIO **tablep)
188 PerlIO *table = *tablep;
192 PerlIO_cleantable((PerlIO **) &(table[0]));
193 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
210 PerlIO_cleantable(&_perlio);
214 PerlIO_pop(PerlIO *f)
219 (*l->tab->Popped)(f);
225 /*--------------------------------------------------------------------------------------*/
226 /* XS Interface for perl code */
232 char *s = GvNAME(gv);
233 STRLEN l = GvNAMELEN(gv);
234 PerlIO_debug("%.*s\n",(int) l,s);
238 XS(XS_perlio_unimport)
242 char *s = GvNAME(gv);
243 STRLEN l = GvNAMELEN(gv);
244 PerlIO_debug("%.*s\n",(int) l,s);
249 PerlIO_find_layer(const char *name, STRLEN len)
256 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
257 if (svp && (sv = *svp) && SvROK(sv))
264 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
268 IO *io = GvIOn((GV *)SvRV(sv));
269 PerlIO *ifp = IoIFP(io);
270 PerlIO *ofp = IoOFP(io);
271 AV *av = (AV *) mg->mg_obj;
272 Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
278 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
282 IO *io = GvIOn((GV *)SvRV(sv));
283 PerlIO *ifp = IoIFP(io);
284 PerlIO *ofp = IoOFP(io);
285 AV *av = (AV *) mg->mg_obj;
286 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
292 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
294 Perl_warn(aTHX_ "clear %_",sv);
299 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
301 Perl_warn(aTHX_ "free %_",sv);
305 MGVTBL perlio_vtab = {
313 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
316 SV *sv = SvRV(ST(1));
321 sv_magic(sv, (SV *)av, '~', NULL, 0);
323 mg = mg_find(sv,'~');
324 mg->mg_virtual = &perlio_vtab;
326 Perl_warn(aTHX_ "attrib %_",sv);
327 for (i=2; i < items; i++)
330 const char *name = SvPV(ST(i),len);
331 SV *layer = PerlIO_find_layer(name,len);
334 av_push(av,SvREFCNT_inc(layer));
347 PerlIO_define_layer(PerlIO_funcs *tab)
350 HV *stash = gv_stashpv("perlio::Layer", TRUE);
351 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
352 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
356 PerlIO_default_layer(I32 n)
361 PerlIO_funcs *tab = &PerlIO_stdio;
363 if (!PerlIO_layer_hv)
365 const char *s = PerlEnv_getenv("PERLIO");
366 newXS("perlio::import",XS_perlio_import,__FILE__);
367 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
369 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
371 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
372 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
373 PerlIO_define_layer(&PerlIO_unix);
374 PerlIO_define_layer(&PerlIO_perlio);
375 PerlIO_define_layer(&PerlIO_stdio);
376 PerlIO_define_layer(&PerlIO_crlf);
378 PerlIO_define_layer(&PerlIO_mmap);
380 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
385 while (*s && isSPACE((unsigned char)*s))
391 while (*e && !isSPACE((unsigned char)*e))
395 layer = PerlIO_find_layer(s,e-s);
398 PerlIO_debug("Pushing %.*s\n",(e-s),s);
399 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
402 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
408 len = av_len(PerlIO_layer_av);
411 if (PerlIO_stdio.Set_ptrcnt)
413 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
417 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
419 len = av_len(PerlIO_layer_av);
423 svp = av_fetch(PerlIO_layer_av,n,0);
424 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
426 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
428 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
433 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
437 const char *s = names;
447 while (*e && *e != ':' && !isSPACE(*e))
451 SV *layer = PerlIO_find_layer(s,e-s);
454 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
457 PerlIO *new = PerlIO_push(f,tab,mode);
463 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
472 #define PerlIO_default_top() PerlIO_default_layer(-1)
473 #define PerlIO_default_btm() PerlIO_default_layer(0)
481 PerlIO_fdopen(0,"Ir");
482 PerlIO_fdopen(1,"Iw");
483 PerlIO_fdopen(2,"Iw");
488 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
491 Newc('L',l,tab->size,char,PerlIOl);
494 Zero(l,tab->size,char);
498 if ((*l->tab->Pushed)(f,mode) != 0)
507 /*--------------------------------------------------------------------------------------*/
508 /* Given the abstraction above the public API functions */
512 PerlIO_close(PerlIO *f)
514 int code = (*PerlIOBase(f)->tab->Close)(f);
524 PerlIO_fileno(PerlIO *f)
526 return (*PerlIOBase(f)->tab->Fileno)(f);
533 PerlIO_fdopen(int fd, const char *mode)
535 PerlIO_funcs *tab = PerlIO_default_top();
538 return (*tab->Fdopen)(tab,fd,mode);
543 PerlIO_open(const char *path, const char *mode)
545 PerlIO_funcs *tab = PerlIO_default_top();
548 return (*tab->Open)(tab,path,mode);
553 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
558 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
560 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
566 return PerlIO_open(path,mode);
571 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
573 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
578 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
580 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
585 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
587 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
592 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
594 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
599 PerlIO_tell(PerlIO *f)
601 return (*PerlIOBase(f)->tab->Tell)(f);
606 PerlIO_flush(PerlIO *f)
610 return (*PerlIOBase(f)->tab->Flush)(f);
614 PerlIO **table = &_perlio;
619 table = (PerlIO **)(f++);
620 for (i=1; i < PERLIO_TABLE_SIZE; i++)
622 if (*f && PerlIO_flush(f) != 0)
633 PerlIO_fill(PerlIO *f)
635 return (*PerlIOBase(f)->tab->Fill)(f);
640 PerlIO_isutf8(PerlIO *f)
642 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
647 PerlIO_eof(PerlIO *f)
649 return (*PerlIOBase(f)->tab->Eof)(f);
654 PerlIO_error(PerlIO *f)
656 return (*PerlIOBase(f)->tab->Error)(f);
659 #undef PerlIO_clearerr
661 PerlIO_clearerr(PerlIO *f)
663 (*PerlIOBase(f)->tab->Clearerr)(f);
666 #undef PerlIO_setlinebuf
668 PerlIO_setlinebuf(PerlIO *f)
670 (*PerlIOBase(f)->tab->Setlinebuf)(f);
673 #undef PerlIO_has_base
675 PerlIO_has_base(PerlIO *f)
679 return (PerlIOBase(f)->tab->Get_base != NULL);
684 #undef PerlIO_fast_gets
686 PerlIO_fast_gets(PerlIO *f)
690 PerlIOl *l = PerlIOBase(f);
691 return (l->tab->Set_ptrcnt != NULL);
696 #undef PerlIO_has_cntptr
698 PerlIO_has_cntptr(PerlIO *f)
702 PerlIO_funcs *tab = PerlIOBase(f)->tab;
703 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
708 #undef PerlIO_canset_cnt
710 PerlIO_canset_cnt(PerlIO *f)
714 PerlIOl *l = PerlIOBase(f);
715 return (l->tab->Set_ptrcnt != NULL);
720 #undef PerlIO_get_base
722 PerlIO_get_base(PerlIO *f)
724 return (*PerlIOBase(f)->tab->Get_base)(f);
727 #undef PerlIO_get_bufsiz
729 PerlIO_get_bufsiz(PerlIO *f)
731 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
734 #undef PerlIO_get_ptr
736 PerlIO_get_ptr(PerlIO *f)
738 return (*PerlIOBase(f)->tab->Get_ptr)(f);
741 #undef PerlIO_get_cnt
743 PerlIO_get_cnt(PerlIO *f)
745 return (*PerlIOBase(f)->tab->Get_cnt)(f);
748 #undef PerlIO_set_cnt
750 PerlIO_set_cnt(PerlIO *f,int cnt)
752 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
755 #undef PerlIO_set_ptrcnt
757 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
759 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
762 /*--------------------------------------------------------------------------------------*/
763 /* "Methods" of the "base class" */
766 PerlIOBase_fileno(PerlIO *f)
768 return PerlIO_fileno(PerlIONext(f));
772 PerlIOBase_pushed(PerlIO *f, const char *mode)
774 PerlIOl *l = PerlIOBase(f);
775 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
776 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
782 l->flags = PERLIO_F_CANREAD;
785 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
788 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
799 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
802 l->flags |= PERLIO_F_BINARY;
814 l->flags |= l->next->flags &
815 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
816 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
823 PerlIOBase_popped(PerlIO *f)
829 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
831 Off_t old = PerlIO_tell(f);
832 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
834 Off_t new = PerlIO_tell(f);
841 PerlIOBase_noop_ok(PerlIO *f)
847 PerlIOBase_noop_fail(PerlIO *f)
853 PerlIOBase_close(PerlIO *f)
856 if (PerlIO_flush(f) != 0)
858 if (PerlIO_close(PerlIONext(f)) != 0)
860 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
865 PerlIOBase_eof(PerlIO *f)
869 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
875 PerlIOBase_error(PerlIO *f)
879 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
885 PerlIOBase_clearerr(PerlIO *f)
889 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
894 PerlIOBase_setlinebuf(PerlIO *f)
899 /*--------------------------------------------------------------------------------------*/
900 /* Bottom-most level for UNIX-like case */
904 struct _PerlIO base; /* The generic part */
905 int fd; /* UNIX like file descriptor */
906 int oflags; /* open/fcntl flags */
910 PerlIOUnix_oflags(const char *mode)
925 oflags = O_CREAT|O_TRUNC;
936 oflags = O_CREAT|O_APPEND;
946 if (*mode || oflags == -1)
955 PerlIOUnix_fileno(PerlIO *f)
957 return PerlIOSelf(f,PerlIOUnix)->fd;
961 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
968 int oflags = PerlIOUnix_oflags(mode);
971 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
974 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
981 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
984 int oflags = PerlIOUnix_oflags(mode);
987 int fd = PerlLIO_open3(path,oflags,0666);
990 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
993 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1000 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1002 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1003 int oflags = PerlIOUnix_oflags(mode);
1004 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1005 (*PerlIOBase(f)->tab->Close)(f);
1008 int fd = PerlLIO_open3(path,oflags,0666);
1013 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1021 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1023 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1024 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1028 SSize_t len = PerlLIO_read(fd,vbuf,count);
1029 if (len >= 0 || errno != EINTR)
1032 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1033 else if (len == 0 && count != 0)
1034 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1041 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1043 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1046 SSize_t len = PerlLIO_write(fd,vbuf,count);
1047 if (len >= 0 || errno != EINTR)
1050 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1057 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1059 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1060 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1061 return (new == (Off_t) -1) ? -1 : 0;
1065 PerlIOUnix_tell(PerlIO *f)
1067 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1071 PerlIOUnix_close(PerlIO *f)
1073 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1075 while (PerlLIO_close(fd) != 0)
1085 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1090 PerlIO_funcs PerlIO_unix = {
1106 PerlIOBase_noop_ok, /* flush */
1107 PerlIOBase_noop_fail, /* fill */
1110 PerlIOBase_clearerr,
1111 PerlIOBase_setlinebuf,
1112 NULL, /* get_base */
1113 NULL, /* get_bufsiz */
1116 NULL, /* set_ptrcnt */
1119 /*--------------------------------------------------------------------------------------*/
1120 /* stdio as a layer */
1124 struct _PerlIO base;
1125 FILE * stdio; /* The stream */
1129 PerlIOStdio_fileno(PerlIO *f)
1131 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1136 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1164 stdio = fdopen(fd,mode);
1167 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1174 #undef PerlIO_importFILE
1176 PerlIO_importFILE(FILE *stdio, int fl)
1181 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1188 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1191 FILE *stdio = fopen(path,mode);
1194 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1201 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1203 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1204 FILE *stdio = freopen(path,mode,s->stdio);
1212 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1214 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1218 STDCHAR *buf = (STDCHAR *) vbuf;
1219 /* Perl is expecting PerlIO_getc() to fill the buffer
1220 * Linux's stdio does not do that for fread()
1230 got = fread(vbuf,1,count,s);
1235 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1237 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1238 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1242 int ch = *buf-- & 0xff;
1243 if (ungetc(ch,s) != ch)
1252 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1254 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1258 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1260 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1261 return fseek(stdio,offset,whence);
1265 PerlIOStdio_tell(PerlIO *f)
1267 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1268 return ftell(stdio);
1272 PerlIOStdio_close(PerlIO *f)
1274 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1278 PerlIOStdio_flush(PerlIO *f)
1280 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1281 return fflush(stdio);
1285 PerlIOStdio_fill(PerlIO *f)
1287 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1289 if (fflush(stdio) != 0)
1292 if (c == EOF || ungetc(c,stdio) != c)
1298 PerlIOStdio_eof(PerlIO *f)
1300 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1304 PerlIOStdio_error(PerlIO *f)
1306 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1310 PerlIOStdio_clearerr(PerlIO *f)
1312 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1316 PerlIOStdio_setlinebuf(PerlIO *f)
1318 #ifdef HAS_SETLINEBUF
1319 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1321 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1327 PerlIOStdio_get_base(PerlIO *f)
1329 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1330 return FILE_base(stdio);
1334 PerlIOStdio_get_bufsiz(PerlIO *f)
1336 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1337 return FILE_bufsiz(stdio);
1341 #ifdef USE_STDIO_PTR
1343 PerlIOStdio_get_ptr(PerlIO *f)
1345 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1346 return FILE_ptr(stdio);
1350 PerlIOStdio_get_cnt(PerlIO *f)
1352 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1353 return FILE_cnt(stdio);
1357 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1359 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1362 #ifdef STDIO_PTR_LVALUE
1363 FILE_ptr(stdio) = ptr;
1364 #ifdef STDIO_PTR_LVAL_SETS_CNT
1365 if (FILE_cnt(stdio) != (cnt))
1368 assert(FILE_cnt(stdio) == (cnt));
1371 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1372 /* Setting ptr _does_ change cnt - we are done */
1375 #else /* STDIO_PTR_LVALUE */
1377 #endif /* STDIO_PTR_LVALUE */
1379 /* Now (or only) set cnt */
1380 #ifdef STDIO_CNT_LVALUE
1381 FILE_cnt(stdio) = cnt;
1382 #else /* STDIO_CNT_LVALUE */
1383 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1384 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1385 #else /* STDIO_PTR_LVAL_SETS_CNT */
1387 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1388 #endif /* STDIO_CNT_LVALUE */
1393 PerlIO_funcs PerlIO_stdio = {
1395 sizeof(PerlIOStdio),
1413 PerlIOStdio_clearerr,
1414 PerlIOStdio_setlinebuf,
1416 PerlIOStdio_get_base,
1417 PerlIOStdio_get_bufsiz,
1422 #ifdef USE_STDIO_PTR
1423 PerlIOStdio_get_ptr,
1424 PerlIOStdio_get_cnt,
1425 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1426 PerlIOStdio_set_ptrcnt
1427 #else /* STDIO_PTR_LVALUE */
1429 #endif /* STDIO_PTR_LVALUE */
1430 #else /* USE_STDIO_PTR */
1434 #endif /* USE_STDIO_PTR */
1437 #undef PerlIO_exportFILE
1439 PerlIO_exportFILE(PerlIO *f, int fl)
1442 /* Should really push stdio discipline when we have them */
1443 return fdopen(PerlIO_fileno(f),"r+");
1446 #undef PerlIO_findFILE
1448 PerlIO_findFILE(PerlIO *f)
1450 return PerlIO_exportFILE(f,0);
1453 #undef PerlIO_releaseFILE
1455 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1459 /*--------------------------------------------------------------------------------------*/
1460 /* perlio buffer layer */
1463 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1465 PerlIO_funcs *tab = PerlIO_default_btm();
1473 f = (*tab->Fdopen)(tab,fd,mode);
1476 /* Initial stderr is unbuffered */
1477 if (!init || fd != 2)
1479 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1480 b->posn = PerlIO_tell(PerlIONext(f));
1487 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1489 PerlIO_funcs *tab = PerlIO_default_btm();
1490 PerlIO *f = (*tab->Open)(tab,path,mode);
1493 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1494 b->posn = PerlIO_tell(PerlIONext(f));
1500 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1502 PerlIO *next = PerlIONext(f);
1503 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1505 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1508 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1509 b->posn = PerlIO_tell(PerlIONext(f));
1514 /* This "flush" is akin to sfio's sync in that it handles files in either
1518 PerlIOBuf_flush(PerlIO *f)
1520 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1522 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1524 /* write() the buffer */
1525 STDCHAR *p = b->buf;
1529 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1536 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1541 b->posn += (p - b->buf);
1543 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1545 /* Note position change */
1546 b->posn += (b->ptr - b->buf);
1547 if (b->ptr < b->end)
1549 /* We did not consume all of it */
1550 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1552 b->posn = PerlIO_tell(PerlIONext(f));
1556 b->ptr = b->end = b->buf;
1557 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1558 if (PerlIO_flush(PerlIONext(f)) != 0)
1564 PerlIOBuf_fill(PerlIO *f)
1566 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1568 if (PerlIO_flush(f) != 0)
1570 b->ptr = b->end = b->buf;
1571 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1575 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1577 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1580 b->end = b->buf+avail;
1581 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1586 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1588 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1589 STDCHAR *buf = (STDCHAR *) vbuf;
1595 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1599 SSize_t avail = (b->end - b->ptr);
1600 if ((SSize_t) count < avail)
1604 Copy(b->ptr,buf,avail,char);
1610 if (count && (b->ptr >= b->end))
1612 if (PerlIO_fill(f) != 0)
1622 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1624 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1625 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1628 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1634 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1636 avail = (b->ptr - b->buf);
1637 if (avail > (SSize_t) count)
1644 if (avail > (SSize_t) count)
1646 b->end = b->ptr + avail;
1653 Copy(buf,b->ptr,avail,char);
1657 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1664 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1666 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1667 const STDCHAR *buf = (const STDCHAR *) vbuf;
1671 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1675 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1676 if ((SSize_t) count < avail)
1678 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1679 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1699 Copy(buf,b->ptr,avail,char);
1706 if (b->ptr >= (b->buf + b->bufsiz))
1713 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1715 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1716 int code = PerlIO_flush(f);
1719 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1720 code = PerlIO_seek(PerlIONext(f),offset,whence);
1723 b->posn = PerlIO_tell(PerlIONext(f));
1730 PerlIOBuf_tell(PerlIO *f)
1732 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1733 Off_t posn = b->posn;
1735 posn += (b->ptr - b->buf);
1740 PerlIOBuf_close(PerlIO *f)
1742 IV code = PerlIOBase_close(f);
1743 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1744 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1749 b->ptr = b->end = b->buf;
1750 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1755 PerlIOBuf_setlinebuf(PerlIO *f)
1759 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1764 PerlIOBuf_get_ptr(PerlIO *f)
1766 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1773 PerlIOBuf_get_cnt(PerlIO *f)
1775 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1778 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1779 return (b->end - b->ptr);
1784 PerlIOBuf_get_base(PerlIO *f)
1786 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1791 New('B',b->buf,b->bufsiz,STDCHAR);
1794 b->buf = (STDCHAR *)&b->oneword;
1795 b->bufsiz = sizeof(b->oneword);
1804 PerlIOBuf_bufsiz(PerlIO *f)
1806 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1809 return (b->end - b->buf);
1813 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1815 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1819 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1822 assert(PerlIO_get_cnt(f) == cnt);
1823 assert(b->ptr >= b->buf);
1825 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1828 PerlIO_funcs PerlIO_perlio = {
1848 PerlIOBase_clearerr,
1849 PerlIOBuf_setlinebuf,
1854 PerlIOBuf_set_ptrcnt,
1857 /*--------------------------------------------------------------------------------------*/
1858 /* crlf - translation currently just a copy of perlio to prove
1859 that extra buffering which real one will do is not an issue.
1862 PerlIO_funcs PerlIO_crlf = {
1882 PerlIOBase_clearerr,
1883 PerlIOBuf_setlinebuf,
1888 PerlIOBuf_set_ptrcnt,
1892 /*--------------------------------------------------------------------------------------*/
1893 /* mmap as "buffer" layer */
1897 PerlIOBuf base; /* PerlIOBuf stuff */
1898 Mmap_t mptr; /* Mapped address */
1899 Size_t len; /* mapped length */
1900 STDCHAR *bbuf; /* malloced buffer if map fails */
1904 static size_t page_size = 0;
1907 PerlIOMmap_map(PerlIO *f)
1910 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1911 PerlIOBuf *b = &m->base;
1912 IV flags = PerlIOBase(f)->flags;
1916 if (flags & PERLIO_F_CANREAD)
1918 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1919 int fd = PerlIO_fileno(f);
1921 code = fstat(fd,&st);
1922 if (code == 0 && S_ISREG(st.st_mode))
1924 SSize_t len = st.st_size - b->posn;
1929 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1931 SETERRNO(0,SS$_NORMAL);
1932 # ifdef _SC_PAGESIZE
1933 page_size = sysconf(_SC_PAGESIZE);
1935 page_size = sysconf(_SC_PAGE_SIZE);
1937 if ((long)page_size < 0) {
1942 (void)SvUPGRADE(error, SVt_PV);
1943 msg = SvPVx(error, n_a);
1944 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1947 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1951 # ifdef HAS_GETPAGESIZE
1952 page_size = getpagesize();
1954 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
1955 page_size = PAGESIZE; /* compiletime, bad */
1959 if ((IV)page_size <= 0)
1960 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1964 /* This is a hack - should never happen - open should have set it ! */
1965 b->posn = PerlIO_tell(PerlIONext(f));
1967 posn = (b->posn / page_size) * page_size;
1968 len = st.st_size - posn;
1969 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1970 if (m->mptr && m->mptr != (Mmap_t) -1)
1972 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1973 madvise(m->mptr, len, MADV_SEQUENTIAL);
1975 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1976 b->end = ((STDCHAR *)m->mptr) + len;
1977 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
1988 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1990 b->ptr = b->end = b->ptr;
1999 PerlIOMmap_unmap(PerlIO *f)
2001 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2002 PerlIOBuf *b = &m->base;
2008 code = munmap(m->mptr, m->len);
2012 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2015 b->ptr = b->end = b->buf;
2016 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2022 PerlIOMmap_get_base(PerlIO *f)
2024 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2025 PerlIOBuf *b = &m->base;
2026 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2028 /* Already have a readbuffer in progress */
2033 /* We have a write buffer or flushed PerlIOBuf read buffer */
2034 m->bbuf = b->buf; /* save it in case we need it again */
2035 b->buf = NULL; /* Clear to trigger below */
2039 PerlIOMmap_map(f); /* Try and map it */
2042 /* Map did not work - recover PerlIOBuf buffer if we have one */
2046 b->ptr = b->end = b->buf;
2049 return PerlIOBuf_get_base(f);
2053 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2055 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2056 PerlIOBuf *b = &m->base;
2057 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2059 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2062 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2067 /* Loose the unwritable mapped buffer */
2069 /* If flush took the "buffer" see if we have one from before */
2070 if (!b->buf && m->bbuf)
2074 PerlIOBuf_get_base(f);
2078 return PerlIOBuf_unread(f,vbuf,count);
2082 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2084 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2085 PerlIOBuf *b = &m->base;
2086 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2088 /* No, or wrong sort of, buffer */
2091 if (PerlIOMmap_unmap(f) != 0)
2094 /* If unmap took the "buffer" see if we have one from before */
2095 if (!b->buf && m->bbuf)
2099 PerlIOBuf_get_base(f);
2103 return PerlIOBuf_write(f,vbuf,count);
2107 PerlIOMmap_flush(PerlIO *f)
2109 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2110 PerlIOBuf *b = &m->base;
2111 IV code = PerlIOBuf_flush(f);
2112 /* Now we are "synced" at PerlIOBuf level */
2117 /* Unmap the buffer */
2118 if (PerlIOMmap_unmap(f) != 0)
2123 /* We seem to have a PerlIOBuf buffer which was not mapped
2124 * remember it in case we need one later
2133 PerlIOMmap_fill(PerlIO *f)
2135 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2136 IV code = PerlIO_flush(f);
2137 if (code == 0 && !b->buf)
2139 code = PerlIOMmap_map(f);
2141 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2143 code = PerlIOBuf_fill(f);
2149 PerlIOMmap_close(PerlIO *f)
2151 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2152 PerlIOBuf *b = &m->base;
2153 IV code = PerlIO_flush(f);
2158 b->ptr = b->end = b->buf;
2160 if (PerlIOBuf_close(f) != 0)
2166 PerlIO_funcs PerlIO_mmap = {
2186 PerlIOBase_clearerr,
2187 PerlIOBuf_setlinebuf,
2188 PerlIOMmap_get_base,
2192 PerlIOBuf_set_ptrcnt,
2195 #endif /* HAS_MMAP */
2202 atexit(&PerlIO_cleanup);
2211 PerlIO_stdstreams();
2215 #undef PerlIO_stdout
2220 PerlIO_stdstreams();
2224 #undef PerlIO_stderr
2229 PerlIO_stdstreams();
2233 /*--------------------------------------------------------------------------------------*/
2235 #undef PerlIO_getname
2237 PerlIO_getname(PerlIO *f, char *buf)
2240 Perl_croak(aTHX_ "Don't know how to get file name");
2245 /*--------------------------------------------------------------------------------------*/
2246 /* Functions which can be called on any kind of PerlIO implemented
2252 PerlIO_getc(PerlIO *f)
2255 SSize_t count = PerlIO_read(f,buf,1);
2258 return (unsigned char) buf[0];
2263 #undef PerlIO_ungetc
2265 PerlIO_ungetc(PerlIO *f, int ch)
2270 if (PerlIO_unread(f,&buf,1) == 1)
2278 PerlIO_putc(PerlIO *f, int ch)
2281 return PerlIO_write(f,&buf,1);
2286 PerlIO_puts(PerlIO *f, const char *s)
2288 STRLEN len = strlen(s);
2289 return PerlIO_write(f,s,len);
2292 #undef PerlIO_rewind
2294 PerlIO_rewind(PerlIO *f)
2296 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2300 #undef PerlIO_vprintf
2302 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2305 SV *sv = newSVpvn("",0);
2308 sv_vcatpvf(sv, fmt, &ap);
2310 return PerlIO_write(f,s,len);
2313 #undef PerlIO_printf
2315 PerlIO_printf(PerlIO *f,const char *fmt,...)
2320 result = PerlIO_vprintf(f,fmt,ap);
2325 #undef PerlIO_stdoutf
2327 PerlIO_stdoutf(const char *fmt,...)
2332 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2337 #undef PerlIO_tmpfile
2339 PerlIO_tmpfile(void)
2342 /* I have no idea how portable mkstemp() is ... */
2343 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2344 int fd = mkstemp(SvPVX(sv));
2348 f = PerlIO_fdopen(fd,"w+");
2351 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2353 PerlLIO_unlink(SvPVX(sv));
2362 #endif /* USE_SFIO */
2363 #endif /* PERLIO_IS_STDIO */
2365 /*======================================================================================*/
2366 /* Now some functions in terms of above which may be needed even if
2367 we are not in true PerlIO mode
2371 #undef PerlIO_setpos
2373 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2375 return PerlIO_seek(f,*pos,0);
2378 #ifndef PERLIO_IS_STDIO
2379 #undef PerlIO_setpos
2381 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2383 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2384 return fsetpos64(f, pos);
2386 return fsetpos(f, pos);
2393 #undef PerlIO_getpos
2395 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2397 *pos = PerlIO_tell(f);
2398 return *pos == -1 ? -1 : 0;
2401 #ifndef PERLIO_IS_STDIO
2402 #undef PerlIO_getpos
2404 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2406 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2407 return fgetpos64(f, pos);
2409 return fgetpos(f, pos);
2415 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2418 vprintf(char *pat, char *args)
2420 _doprnt(pat, args, stdout);
2421 return 0; /* wrong, but perl doesn't use the return value */
2425 vfprintf(FILE *fd, char *pat, char *args)
2427 _doprnt(pat, args, fd);
2428 return 0; /* wrong, but perl doesn't use the return value */
2433 #ifndef PerlIO_vsprintf
2435 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2437 int val = vsprintf(s, fmt, ap);
2440 if (strlen(s) >= (STRLEN)n)
2443 (void)PerlIO_puts(Perl_error_log,
2444 "panic: sprintf overflow - memory corrupted!\n");
2452 #ifndef PerlIO_sprintf
2454 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2459 result = PerlIO_vsprintf(s, n, fmt, ap);
2465 #endif /* !PERL_IMPLICIT_SYS */