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
31 #undef PerlMemShared_calloc
32 #define PerlMemShared_calloc(x,y) calloc(x,y)
33 #undef PerlMemShared_free
34 #define PerlMemShared_free(x) free(x)
39 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
41 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
45 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
51 perlsio_binmode(FILE *fp, int iotype, int mode)
53 /* This used to be contents of do_binmode in doio.c */
55 # if defined(atarist) || defined(__MINT__)
58 ((FILE*)fp)->_flag |= _IOBIN;
60 ((FILE*)fp)->_flag &= ~ _IOBIN;
65 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
66 # if defined(WIN32) && defined(__BORLANDC__)
67 /* The translation mode of the stream is maintained independent
68 * of the translation mode of the fd in the Borland RTL (heavy
69 * digging through their runtime sources reveal). User has to
70 * set the mode explicitly for the stream (though they don't
71 * document this anywhere). GSAR 97-5-24
77 fp->flags &= ~ _F_BIN;
85 # if defined(USEMYBINMODE)
86 if (my_binmode(fp, iotype, mode) != FALSE)
97 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
99 return perlsio_binmode(fp,iotype,mode);
105 #ifdef PERLIO_IS_STDIO
110 /* Does nothing (yet) except force this file to be included
111 in perl binary. That allows this file to force inclusion
112 of other functions that may be required by loadable
113 extensions e.g. for FileHandle::tmpfile
117 #undef PerlIO_tmpfile
124 #else /* PERLIO_IS_STDIO */
131 /* This section is just to make sure these functions
132 get pulled in from libsfio.a
135 #undef PerlIO_tmpfile
145 /* Force this file to be included in perl binary. Which allows
146 * this file to force inclusion of other functions that may be
147 * required by loadable extensions e.g. for FileHandle::tmpfile
151 * sfio does its own 'autoflush' on stdout in common cases.
152 * Flush results in a lot of lseek()s to regular files and
153 * lot of small writes to pipes.
155 sfset(sfstdout,SF_SHARE,0);
159 /*======================================================================================*/
160 /* Implement all the PerlIO interface ourselves.
165 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
170 #include <sys/mman.h>
175 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
178 PerlIO_debug(const char *fmt,...)
186 char *s = PerlEnv_getenv("PERLIO_DEBUG");
188 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
195 SV *sv = newSVpvn("",0);
198 s = CopFILE(PL_curcop);
201 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
202 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
205 PerlLIO_write(dbg,s,len);
211 /*--------------------------------------------------------------------------------------*/
213 /* Inner level routines */
215 /* Table of pointers to the PerlIO structs (malloc'ed) */
216 PerlIO *_perlio = NULL;
217 #define PERLIO_TABLE_SIZE 64
220 PerlIO_allocate(pTHX)
222 /* Find a free slot in the table, allocating new table as necessary */
229 last = (PerlIO **)(f);
230 for (i=1; i < PERLIO_TABLE_SIZE; i++)
238 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
248 PerlIO_cleantable(pTHX_ PerlIO **tablep)
250 PerlIO *table = *tablep;
254 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
255 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
263 PerlMemShared_free(table);
275 PerlIO_cleantable(aTHX_ &_perlio);
279 PerlIO_pop(PerlIO *f)
285 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
286 (*l->tab->Popped)(f);
288 PerlMemShared_free(l);
292 /*--------------------------------------------------------------------------------------*/
293 /* XS Interface for perl code */
299 char *s = GvNAME(gv);
300 STRLEN l = GvNAMELEN(gv);
301 PerlIO_debug("%.*s\n",(int) l,s);
305 XS(XS_perlio_unimport)
309 char *s = GvNAME(gv);
310 STRLEN l = GvNAMELEN(gv);
311 PerlIO_debug("%.*s\n",(int) l,s);
316 PerlIO_find_layer(const char *name, STRLEN len)
321 if ((SSize_t) len <= 0)
323 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
324 if (svp && (sv = *svp) && SvROK(sv))
331 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
335 IO *io = GvIOn((GV *)SvRV(sv));
336 PerlIO *ifp = IoIFP(io);
337 PerlIO *ofp = IoOFP(io);
338 AV *av = (AV *) mg->mg_obj;
339 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
345 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
349 IO *io = GvIOn((GV *)SvRV(sv));
350 PerlIO *ifp = IoIFP(io);
351 PerlIO *ofp = IoOFP(io);
352 AV *av = (AV *) mg->mg_obj;
353 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
359 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
361 Perl_warn(aTHX_ "clear %"SVf,sv);
366 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
368 Perl_warn(aTHX_ "free %"SVf,sv);
372 MGVTBL perlio_vtab = {
380 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
383 SV *sv = SvRV(ST(1));
388 sv_magic(sv, (SV *)av, '~', NULL, 0);
390 mg = mg_find(sv,'~');
391 mg->mg_virtual = &perlio_vtab;
393 Perl_warn(aTHX_ "attrib %"SVf,sv);
394 for (i=2; i < items; i++)
397 const char *name = SvPV(ST(i),len);
398 SV *layer = PerlIO_find_layer(name,len);
401 av_push(av,SvREFCNT_inc(layer));
414 PerlIO_define_layer(PerlIO_funcs *tab)
417 HV *stash = gv_stashpv("perlio::Layer", TRUE);
418 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
419 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
423 PerlIO_default_layer(I32 n)
428 PerlIO_funcs *tab = &PerlIO_stdio;
430 if (!PerlIO_layer_hv)
432 const char *s = PerlEnv_getenv("PERLIO");
433 newXS("perlio::import",XS_perlio_import,__FILE__);
434 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
436 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
438 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
439 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
440 PerlIO_define_layer(&PerlIO_unix);
441 PerlIO_define_layer(&PerlIO_perlio);
442 PerlIO_define_layer(&PerlIO_stdio);
443 PerlIO_define_layer(&PerlIO_crlf);
445 PerlIO_define_layer(&PerlIO_mmap);
447 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
452 while (*s && isSPACE((unsigned char)*s))
458 while (*e && !isSPACE((unsigned char)*e))
462 layer = PerlIO_find_layer(s,e-s);
465 PerlIO_debug("Pushing %.*s\n",(e-s),s);
466 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
469 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
475 len = av_len(PerlIO_layer_av);
478 if (O_BINARY != O_TEXT)
480 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
484 if (PerlIO_stdio.Set_ptrcnt)
486 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
490 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
493 len = av_len(PerlIO_layer_av);
497 svp = av_fetch(PerlIO_layer_av,n,0);
498 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
500 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
502 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
506 #define PerlIO_default_top() PerlIO_default_layer(-1)
507 #define PerlIO_default_btm() PerlIO_default_layer(0)
515 PerlIO_allocate(aTHX);
516 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
517 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
518 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
523 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
527 l = PerlMemShared_calloc(tab->size,sizeof(char));
530 Zero(l,tab->size,char);
534 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
535 if ((*l->tab->Pushed)(f,mode) != 0)
545 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
549 const char *s = names;
559 while (*e && *e != ':' && !isSPACE(*e))
563 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
565 /* Pop back to bottom layer */
569 while (PerlIONext(f))
577 SV *layer = PerlIO_find_layer(s,e-s);
580 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
583 PerlIO *new = PerlIO_push(f,tab,mode);
589 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
601 /*--------------------------------------------------------------------------------------*/
602 /* Given the abstraction above the public API functions */
605 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
607 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
608 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
609 if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
615 if (PerlIOBase(top)->tab == &PerlIO_crlf)
618 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
621 top = PerlIONext(top);
624 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
629 PerlIO__close(PerlIO *f)
631 return (*PerlIOBase(f)->tab->Close)(f);
634 #undef PerlIO_fdupopen
636 PerlIO_fdupopen(pTHX_ PerlIO *f)
639 int fd = PerlLIO_dup(PerlIO_fileno(f));
640 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
643 Off_t posn = PerlIO_tell(f);
644 PerlIO_seek(new,posn,SEEK_SET);
651 PerlIO_close(PerlIO *f)
653 int code = (*PerlIOBase(f)->tab->Close)(f);
663 PerlIO_fileno(PerlIO *f)
665 return (*PerlIOBase(f)->tab->Fileno)(f);
672 PerlIO_fdopen(int fd, const char *mode)
674 PerlIO_funcs *tab = PerlIO_default_top();
677 return (*tab->Fdopen)(tab,fd,mode);
682 PerlIO_open(const char *path, const char *mode)
684 PerlIO_funcs *tab = PerlIO_default_top();
687 return (*tab->Open)(tab,path,mode);
692 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
697 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
699 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
705 return PerlIO_open(path,mode);
710 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
712 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
717 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
719 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
724 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
726 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
731 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
733 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
738 PerlIO_tell(PerlIO *f)
740 return (*PerlIOBase(f)->tab->Tell)(f);
745 PerlIO_flush(PerlIO *f)
749 return (*PerlIOBase(f)->tab->Flush)(f);
753 PerlIO **table = &_perlio;
758 table = (PerlIO **)(f++);
759 for (i=1; i < PERLIO_TABLE_SIZE; i++)
761 if (*f && PerlIO_flush(f) != 0)
772 PerlIO_fill(PerlIO *f)
774 return (*PerlIOBase(f)->tab->Fill)(f);
779 PerlIO_isutf8(PerlIO *f)
781 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
786 PerlIO_eof(PerlIO *f)
788 return (*PerlIOBase(f)->tab->Eof)(f);
793 PerlIO_error(PerlIO *f)
795 return (*PerlIOBase(f)->tab->Error)(f);
798 #undef PerlIO_clearerr
800 PerlIO_clearerr(PerlIO *f)
803 (*PerlIOBase(f)->tab->Clearerr)(f);
806 #undef PerlIO_setlinebuf
808 PerlIO_setlinebuf(PerlIO *f)
810 (*PerlIOBase(f)->tab->Setlinebuf)(f);
813 #undef PerlIO_has_base
815 PerlIO_has_base(PerlIO *f)
819 return (PerlIOBase(f)->tab->Get_base != NULL);
824 #undef PerlIO_fast_gets
826 PerlIO_fast_gets(PerlIO *f)
828 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
830 PerlIO_funcs *tab = PerlIOBase(f)->tab;
831 return (tab->Set_ptrcnt != NULL);
836 #undef PerlIO_has_cntptr
838 PerlIO_has_cntptr(PerlIO *f)
842 PerlIO_funcs *tab = PerlIOBase(f)->tab;
843 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
848 #undef PerlIO_canset_cnt
850 PerlIO_canset_cnt(PerlIO *f)
854 PerlIOl *l = PerlIOBase(f);
855 return (l->tab->Set_ptrcnt != NULL);
860 #undef PerlIO_get_base
862 PerlIO_get_base(PerlIO *f)
864 return (*PerlIOBase(f)->tab->Get_base)(f);
867 #undef PerlIO_get_bufsiz
869 PerlIO_get_bufsiz(PerlIO *f)
871 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
874 #undef PerlIO_get_ptr
876 PerlIO_get_ptr(PerlIO *f)
878 PerlIO_funcs *tab = PerlIOBase(f)->tab;
879 if (tab->Get_ptr == NULL)
881 return (*tab->Get_ptr)(f);
884 #undef PerlIO_get_cnt
886 PerlIO_get_cnt(PerlIO *f)
888 PerlIO_funcs *tab = PerlIOBase(f)->tab;
889 if (tab->Get_cnt == NULL)
891 return (*tab->Get_cnt)(f);
894 #undef PerlIO_set_cnt
896 PerlIO_set_cnt(PerlIO *f,int cnt)
898 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
901 #undef PerlIO_set_ptrcnt
903 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
905 PerlIO_funcs *tab = PerlIOBase(f)->tab;
906 if (tab->Set_ptrcnt == NULL)
909 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
911 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
914 /*--------------------------------------------------------------------------------------*/
915 /* "Methods" of the "base class" */
918 PerlIOBase_fileno(PerlIO *f)
920 return PerlIO_fileno(PerlIONext(f));
924 PerlIO_modestr(PerlIO *f,char *buf)
927 IV flags = PerlIOBase(f)->flags;
928 if (flags & PERLIO_F_APPEND)
931 if (flags & PERLIO_F_CANREAD)
936 else if (flags & PERLIO_F_CANREAD)
939 if (flags & PERLIO_F_CANWRITE)
942 else if (flags & PERLIO_F_CANWRITE)
945 if (flags & PERLIO_F_CANREAD)
950 #if O_TEXT != O_BINARY
951 if (!(flags & PERLIO_F_CRLF))
959 PerlIOBase_pushed(PerlIO *f, const char *mode)
961 PerlIOl *l = PerlIOBase(f);
962 const char *omode = mode;
964 PerlIO_funcs *tab = PerlIOBase(f)->tab;
965 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
966 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
967 if (tab->Set_ptrcnt != NULL)
968 l->flags |= PERLIO_F_FASTGETS;
974 l->flags |= PERLIO_F_CANREAD;
977 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
980 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
991 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
994 l->flags &= ~PERLIO_F_CRLF;
997 l->flags |= PERLIO_F_CRLF;
1009 l->flags |= l->next->flags &
1010 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1014 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1015 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1016 l->flags,PerlIO_modestr(f,temp));
1022 PerlIOBase_popped(PerlIO *f)
1027 extern PerlIO_funcs PerlIO_pending;
1030 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1033 Off_t old = PerlIO_tell(f);
1034 if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
1036 Off_t new = PerlIO_tell(f);
1044 PerlIO_push(f,&PerlIO_pending,"r");
1045 return PerlIOBuf_unread(f,vbuf,count);
1050 PerlIOBase_noop_ok(PerlIO *f)
1056 PerlIOBase_noop_fail(PerlIO *f)
1062 PerlIOBase_close(PerlIO *f)
1065 PerlIO *n = PerlIONext(f);
1066 if (PerlIO_flush(f) != 0)
1068 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1070 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1075 PerlIOBase_eof(PerlIO *f)
1079 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1085 PerlIOBase_error(PerlIO *f)
1089 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1095 PerlIOBase_clearerr(PerlIO *f)
1099 PerlIO *n = PerlIONext(f);
1100 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1107 PerlIOBase_setlinebuf(PerlIO *f)
1112 /*--------------------------------------------------------------------------------------*/
1113 /* Bottom-most level for UNIX-like case */
1117 struct _PerlIO base; /* The generic part */
1118 int fd; /* UNIX like file descriptor */
1119 int oflags; /* open/fcntl flags */
1123 PerlIOUnix_oflags(const char *mode)
1138 oflags = O_CREAT|O_TRUNC;
1149 oflags = O_CREAT|O_APPEND;
1165 else if (*mode == 't')
1168 oflags &= ~O_BINARY;
1171 /* Always open in binary mode */
1173 if (*mode || oflags == -1)
1182 PerlIOUnix_fileno(PerlIO *f)
1184 return PerlIOSelf(f,PerlIOUnix)->fd;
1188 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1196 int oflags = PerlIOUnix_oflags(mode);
1199 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1202 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1209 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1213 int oflags = PerlIOUnix_oflags(mode);
1216 int fd = PerlLIO_open3(path,oflags,0666);
1219 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1222 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1229 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1231 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1232 int oflags = PerlIOUnix_oflags(mode);
1233 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1234 (*PerlIOBase(f)->tab->Close)(f);
1238 int fd = PerlLIO_open3(path,oflags,0666);
1243 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1251 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1254 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1255 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1259 SSize_t len = PerlLIO_read(fd,vbuf,count);
1260 if (len >= 0 || errno != EINTR)
1263 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1264 else if (len == 0 && count != 0)
1265 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1272 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1275 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1278 SSize_t len = PerlLIO_write(fd,vbuf,count);
1279 if (len >= 0 || errno != EINTR)
1282 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1289 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1292 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1293 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1294 return (new == (Off_t) -1) ? -1 : 0;
1298 PerlIOUnix_tell(PerlIO *f)
1301 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1302 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1306 PerlIOUnix_close(PerlIO *f)
1309 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1311 while (PerlLIO_close(fd) != 0)
1321 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1326 PerlIO_funcs PerlIO_unix = {
1342 PerlIOBase_noop_ok, /* flush */
1343 PerlIOBase_noop_fail, /* fill */
1346 PerlIOBase_clearerr,
1347 PerlIOBase_setlinebuf,
1348 NULL, /* get_base */
1349 NULL, /* get_bufsiz */
1352 NULL, /* set_ptrcnt */
1355 /*--------------------------------------------------------------------------------------*/
1356 /* stdio as a layer */
1360 struct _PerlIO base;
1361 FILE * stdio; /* The stream */
1365 PerlIOStdio_fileno(PerlIO *f)
1368 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1372 PerlIOStdio_mode(const char *mode,char *tmode)
1379 if (O_BINARY != O_TEXT)
1388 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1407 stdio = PerlSIO_stdin;
1410 stdio = PerlSIO_stdout;
1413 stdio = PerlSIO_stderr;
1419 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1423 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOStdio);
1430 #undef PerlIO_importFILE
1432 PerlIO_importFILE(FILE *stdio, int fl)
1438 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+"),PerlIOStdio);
1445 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1449 FILE *stdio = PerlSIO_fopen(path,mode);
1453 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1454 (mode = PerlIOStdio_mode(mode,tmode))),
1462 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1465 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1467 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1475 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1478 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1482 STDCHAR *buf = (STDCHAR *) vbuf;
1483 /* Perl is expecting PerlIO_getc() to fill the buffer
1484 * Linux's stdio does not do that for fread()
1486 int ch = PerlSIO_fgetc(s);
1494 got = PerlSIO_fread(vbuf,1,count,s);
1499 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1502 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1503 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1507 int ch = *buf-- & 0xff;
1508 if (PerlSIO_ungetc(ch,s) != ch)
1517 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1520 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1524 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1527 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1528 return PerlSIO_fseek(stdio,offset,whence);
1532 PerlIOStdio_tell(PerlIO *f)
1535 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1536 return PerlSIO_ftell(stdio);
1540 PerlIOStdio_close(PerlIO *f)
1544 int optval, optlen = sizeof(int);
1546 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1549 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1550 PerlSIO_fclose(stdio) :
1551 close(PerlIO_fileno(f))
1553 PerlSIO_fclose(stdio)
1560 PerlIOStdio_flush(PerlIO *f)
1563 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1564 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1566 return PerlSIO_fflush(stdio);
1571 /* FIXME: This discards ungetc() and pre-read stuff which is
1572 not right if this is just a "sync" from a layer above
1573 Suspect right design is to do _this_ but not have layer above
1574 flush this layer read-to-read
1576 /* Not writeable - sync by attempting a seek */
1578 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1586 PerlIOStdio_fill(PerlIO *f)
1589 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1591 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1592 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1594 if (PerlSIO_fflush(stdio) != 0)
1597 c = PerlSIO_fgetc(stdio);
1598 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1604 PerlIOStdio_eof(PerlIO *f)
1607 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1611 PerlIOStdio_error(PerlIO *f)
1614 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1618 PerlIOStdio_clearerr(PerlIO *f)
1621 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1625 PerlIOStdio_setlinebuf(PerlIO *f)
1628 #ifdef HAS_SETLINEBUF
1629 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1631 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1637 PerlIOStdio_get_base(PerlIO *f)
1640 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1641 return PerlSIO_get_base(stdio);
1645 PerlIOStdio_get_bufsiz(PerlIO *f)
1648 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1649 return PerlSIO_get_bufsiz(stdio);
1653 #ifdef USE_STDIO_PTR
1655 PerlIOStdio_get_ptr(PerlIO *f)
1658 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1659 return PerlSIO_get_ptr(stdio);
1663 PerlIOStdio_get_cnt(PerlIO *f)
1666 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1667 return PerlSIO_get_cnt(stdio);
1671 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1674 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1677 #ifdef STDIO_PTR_LVALUE
1678 PerlSIO_set_ptr(stdio,ptr);
1679 #ifdef STDIO_PTR_LVAL_SETS_CNT
1680 if (PerlSIO_get_cnt(stdio) != (cnt))
1683 assert(PerlSIO_get_cnt(stdio) == (cnt));
1686 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1687 /* Setting ptr _does_ change cnt - we are done */
1690 #else /* STDIO_PTR_LVALUE */
1692 #endif /* STDIO_PTR_LVALUE */
1694 /* Now (or only) set cnt */
1695 #ifdef STDIO_CNT_LVALUE
1696 PerlSIO_set_cnt(stdio,cnt);
1697 #else /* STDIO_CNT_LVALUE */
1698 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1699 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1700 #else /* STDIO_PTR_LVAL_SETS_CNT */
1702 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1703 #endif /* STDIO_CNT_LVALUE */
1708 PerlIO_funcs PerlIO_stdio = {
1710 sizeof(PerlIOStdio),
1728 PerlIOStdio_clearerr,
1729 PerlIOStdio_setlinebuf,
1731 PerlIOStdio_get_base,
1732 PerlIOStdio_get_bufsiz,
1737 #ifdef USE_STDIO_PTR
1738 PerlIOStdio_get_ptr,
1739 PerlIOStdio_get_cnt,
1740 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1741 PerlIOStdio_set_ptrcnt
1742 #else /* STDIO_PTR_LVALUE */
1744 #endif /* STDIO_PTR_LVALUE */
1745 #else /* USE_STDIO_PTR */
1749 #endif /* USE_STDIO_PTR */
1752 #undef PerlIO_exportFILE
1754 PerlIO_exportFILE(PerlIO *f, int fl)
1757 /* Should really push stdio discipline when we have them */
1758 return fdopen(PerlIO_fileno(f),"r+");
1761 #undef PerlIO_findFILE
1763 PerlIO_findFILE(PerlIO *f)
1765 return PerlIO_exportFILE(f,0);
1768 #undef PerlIO_releaseFILE
1770 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1774 /*--------------------------------------------------------------------------------------*/
1775 /* perlio buffer layer */
1778 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1780 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1781 b->posn = PerlIO_tell(PerlIONext(f));
1782 return PerlIOBase_pushed(f,mode);
1786 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1789 PerlIO_funcs *tab = PerlIO_default_btm();
1797 #if O_BINARY != O_TEXT
1798 /* do something about failing setmode()? --jhi */
1799 PerlLIO_setmode(fd, O_BINARY);
1801 f = (*tab->Fdopen)(tab,fd,mode);
1804 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1805 if (init && fd == 2)
1807 /* Initial stderr is unbuffered */
1808 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1811 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1812 self->name,f,fd,mode,PerlIOBase(f)->flags);
1819 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1821 PerlIO_funcs *tab = PerlIO_default_btm();
1822 PerlIO *f = (*tab->Open)(tab,path,mode);
1825 PerlIO_push(f,self,mode);
1831 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1833 PerlIO *next = PerlIONext(f);
1834 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1836 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1840 /* This "flush" is akin to sfio's sync in that it handles files in either
1844 PerlIOBuf_flush(PerlIO *f)
1846 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1848 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1850 /* write() the buffer */
1851 STDCHAR *p = b->buf;
1853 PerlIO *n = PerlIONext(f);
1856 count = PerlIO_write(n,p,b->ptr - p);
1861 else if (count < 0 || PerlIO_error(n))
1863 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1868 b->posn += (p - b->buf);
1870 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1872 /* Note position change */
1873 b->posn += (b->ptr - b->buf);
1874 if (b->ptr < b->end)
1876 /* We did not consume all of it */
1877 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1879 b->posn = PerlIO_tell(PerlIONext(f));
1883 b->ptr = b->end = b->buf;
1884 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1885 /* FIXME: Is this right for read case ? */
1886 if (PerlIO_flush(PerlIONext(f)) != 0)
1892 PerlIOBuf_fill(PerlIO *f)
1894 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1895 PerlIO *n = PerlIONext(f);
1897 /* FIXME: doing the down-stream flush is a bad idea if it causes
1898 pre-read data in stdio buffer to be discarded
1899 but this is too simplistic - as it skips _our_ hosekeeping
1900 and breaks tell tests.
1901 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1905 if (PerlIO_flush(f) != 0)
1908 b->ptr = b->end = b->buf;
1909 if (PerlIO_fast_gets(n))
1911 /* Layer below is also buffered
1912 * We do _NOT_ want to call its ->Read() because that will loop
1913 * till it gets what we asked for which may hang on a pipe etc.
1914 * Instead take anything it has to hand, or ask it to fill _once_.
1916 avail = PerlIO_get_cnt(n);
1919 avail = PerlIO_fill(n);
1921 avail = PerlIO_get_cnt(n);
1924 if (!PerlIO_error(n) && PerlIO_eof(n))
1930 STDCHAR *ptr = PerlIO_get_ptr(n);
1931 SSize_t cnt = avail;
1932 if (avail > b->bufsiz)
1934 Copy(ptr,b->buf,avail,STDCHAR);
1935 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1940 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1945 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1947 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1950 b->end = b->buf+avail;
1951 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1956 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1958 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1959 STDCHAR *buf = (STDCHAR *) vbuf;
1964 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1968 SSize_t avail = PerlIO_get_cnt(f);
1969 SSize_t take = (count < avail) ? count : avail;
1972 STDCHAR *ptr = PerlIO_get_ptr(f);
1973 Copy(ptr,buf,take,STDCHAR);
1974 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1978 if (count > 0 && avail <= 0)
1980 if (PerlIO_fill(f) != 0)
1984 return (buf - (STDCHAR *) vbuf);
1990 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1992 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1993 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1996 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2002 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2004 avail = (b->ptr - b->buf);
2009 b->end = b->buf + avail;
2011 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2012 b->posn -= b->bufsiz;
2014 if (avail > (SSize_t) count)
2022 Copy(buf,b->ptr,avail,STDCHAR);
2026 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2033 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2035 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2036 const STDCHAR *buf = (const STDCHAR *) vbuf;
2040 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2044 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2045 if ((SSize_t) count < avail)
2047 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2048 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2068 Copy(buf,b->ptr,avail,STDCHAR);
2075 if (b->ptr >= (b->buf + b->bufsiz))
2078 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2084 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2087 if ((code = PerlIO_flush(f)) == 0)
2089 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2090 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2091 code = PerlIO_seek(PerlIONext(f),offset,whence);
2094 b->posn = PerlIO_tell(PerlIONext(f));
2101 PerlIOBuf_tell(PerlIO *f)
2103 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2104 Off_t posn = b->posn;
2106 posn += (b->ptr - b->buf);
2111 PerlIOBuf_close(PerlIO *f)
2114 IV code = PerlIOBase_close(f);
2115 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2116 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2118 PerlMemShared_free(b->buf);
2121 b->ptr = b->end = b->buf;
2122 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2127 PerlIOBuf_setlinebuf(PerlIO *f)
2131 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2136 PerlIOBuf_get_ptr(PerlIO *f)
2138 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2145 PerlIOBuf_get_cnt(PerlIO *f)
2147 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2150 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2151 return (b->end - b->ptr);
2156 PerlIOBuf_get_base(PerlIO *f)
2158 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2164 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2167 b->buf = (STDCHAR *)&b->oneword;
2168 b->bufsiz = sizeof(b->oneword);
2177 PerlIOBuf_bufsiz(PerlIO *f)
2179 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2182 return (b->end - b->buf);
2186 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2188 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2192 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2195 assert(PerlIO_get_cnt(f) == cnt);
2196 assert(b->ptr >= b->buf);
2198 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2201 PerlIO_funcs PerlIO_perlio = {
2221 PerlIOBase_clearerr,
2222 PerlIOBuf_setlinebuf,
2227 PerlIOBuf_set_ptrcnt,
2230 /*--------------------------------------------------------------------------------------*/
2231 /* Temp layer to hold unread chars when cannot do it any other way */
2234 PerlIOPending_fill(PerlIO *f)
2236 /* Should never happen */
2242 PerlIOPending_close(PerlIO *f)
2244 /* A tad tricky - flush pops us, then we close new top */
2246 return PerlIO_close(f);
2250 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2252 /* A tad tricky - flush pops us, then we seek new top */
2254 return PerlIO_seek(f,offset,whence);
2259 PerlIOPending_flush(PerlIO *f)
2261 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2262 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2265 PerlMemShared_free(b->buf);
2273 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2281 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2286 PerlIOPending_pushed(PerlIO *f,const char *mode)
2288 IV code = PerlIOBuf_pushed(f,mode);
2289 PerlIOl *l = PerlIOBase(f);
2290 /* Our PerlIO_fast_gets must match what we are pushed on,
2291 or sv_gets() etc. get muddled when it changes mid-string
2294 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2295 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2300 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2302 SSize_t avail = PerlIO_get_cnt(f);
2307 got = PerlIOBuf_read(f,vbuf,avail);
2309 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2314 PerlIO_funcs PerlIO_pending = {
2322 PerlIOPending_pushed,
2329 PerlIOPending_close,
2330 PerlIOPending_flush,
2334 PerlIOBase_clearerr,
2335 PerlIOBuf_setlinebuf,
2340 PerlIOPending_set_ptrcnt,
2345 /*--------------------------------------------------------------------------------------*/
2346 /* crlf - translation
2347 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2348 to hand back a line at a time and keeping a record of which nl we "lied" about.
2349 On write translate "\n" to CR,LF
2354 PerlIOBuf base; /* PerlIOBuf stuff */
2355 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2359 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2362 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2363 code = PerlIOBuf_pushed(f,mode);
2365 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2366 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2367 PerlIOBase(f)->flags);
2374 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2376 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2382 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2383 return PerlIOBuf_unread(f,vbuf,count);
2386 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2387 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2389 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2395 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2397 b->end = b->ptr = b->buf + b->bufsiz;
2398 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2399 b->posn -= b->bufsiz;
2401 while (count > 0 && b->ptr > b->buf)
2406 if (b->ptr - 2 >= b->buf)
2432 PerlIOCrlf_get_cnt(PerlIO *f)
2434 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2437 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2439 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2440 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2442 STDCHAR *nl = b->ptr;
2444 while (nl < b->end && *nl != 0xd)
2446 if (nl < b->end && *nl == 0xd)
2458 /* Not CR,LF but just CR */
2465 /* Blast - found CR as last char in buffer */
2468 /* They may not care, defer work as long as possible */
2469 return (nl - b->ptr);
2475 b->ptr++; /* say we have read it as far as flush() is concerned */
2476 b->buf++; /* Leave space an front of buffer */
2477 b->bufsiz--; /* Buffer is thus smaller */
2478 code = PerlIO_fill(f); /* Fetch some more */
2479 b->bufsiz++; /* Restore size for next time */
2480 b->buf--; /* Point at space */
2481 b->ptr = nl = b->buf; /* Which is what we hand off */
2482 b->posn--; /* Buffer starts here */
2483 *nl = 0xd; /* Fill in the CR */
2485 goto test; /* fill() call worked */
2486 /* CR at EOF - just fall through */
2491 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2497 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2499 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2500 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2501 IV flags = PerlIOBase(f)->flags;
2511 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2518 /* Test code - delete when it works ... */
2525 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2533 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2534 ptr, chk, flags, c->nl, b->end, cnt);
2541 /* They have taken what we lied about */
2548 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2552 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2554 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2555 return PerlIOBuf_write(f,vbuf,count);
2558 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2559 const STDCHAR *buf = (const STDCHAR *) vbuf;
2560 const STDCHAR *ebuf = buf+count;
2563 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2567 STDCHAR *eptr = b->buf+b->bufsiz;
2568 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2569 while (buf < ebuf && b->ptr < eptr)
2573 if ((b->ptr + 2) > eptr)
2575 /* Not room for both */
2581 *(b->ptr)++ = 0xd; /* CR */
2582 *(b->ptr)++ = 0xa; /* LF */
2584 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2603 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2605 return (buf - (STDCHAR *) vbuf);
2610 PerlIOCrlf_flush(PerlIO *f)
2612 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2618 return PerlIOBuf_flush(f);
2621 PerlIO_funcs PerlIO_crlf = {
2624 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2630 PerlIOBase_noop_ok, /* popped */
2631 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2632 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2633 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2641 PerlIOBase_clearerr,
2642 PerlIOBuf_setlinebuf,
2647 PerlIOCrlf_set_ptrcnt,
2651 /*--------------------------------------------------------------------------------------*/
2652 /* mmap as "buffer" layer */
2656 PerlIOBuf base; /* PerlIOBuf stuff */
2657 Mmap_t mptr; /* Mapped address */
2658 Size_t len; /* mapped length */
2659 STDCHAR *bbuf; /* malloced buffer if map fails */
2662 static size_t page_size = 0;
2665 PerlIOMmap_map(PerlIO *f)
2668 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2669 PerlIOBuf *b = &m->base;
2670 IV flags = PerlIOBase(f)->flags;
2674 if (flags & PERLIO_F_CANREAD)
2676 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2677 int fd = PerlIO_fileno(f);
2679 code = fstat(fd,&st);
2680 if (code == 0 && S_ISREG(st.st_mode))
2682 SSize_t len = st.st_size - b->posn;
2687 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2689 SETERRNO(0,SS$_NORMAL);
2690 # ifdef _SC_PAGESIZE
2691 page_size = sysconf(_SC_PAGESIZE);
2693 page_size = sysconf(_SC_PAGE_SIZE);
2695 if ((long)page_size < 0) {
2700 (void)SvUPGRADE(error, SVt_PV);
2701 msg = SvPVx(error, n_a);
2702 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2705 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2709 # ifdef HAS_GETPAGESIZE
2710 page_size = getpagesize();
2712 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2713 page_size = PAGESIZE; /* compiletime, bad */
2717 if ((IV)page_size <= 0)
2718 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2722 /* This is a hack - should never happen - open should have set it ! */
2723 b->posn = PerlIO_tell(PerlIONext(f));
2725 posn = (b->posn / page_size) * page_size;
2726 len = st.st_size - posn;
2727 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2728 if (m->mptr && m->mptr != (Mmap_t) -1)
2730 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2731 madvise(m->mptr, len, MADV_SEQUENTIAL);
2733 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2734 b->end = ((STDCHAR *)m->mptr) + len;
2735 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2746 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2748 b->ptr = b->end = b->ptr;
2757 PerlIOMmap_unmap(PerlIO *f)
2759 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2760 PerlIOBuf *b = &m->base;
2766 code = munmap(m->mptr, m->len);
2770 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2773 b->ptr = b->end = b->buf;
2774 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2780 PerlIOMmap_get_base(PerlIO *f)
2782 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2783 PerlIOBuf *b = &m->base;
2784 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2786 /* Already have a readbuffer in progress */
2791 /* We have a write buffer or flushed PerlIOBuf read buffer */
2792 m->bbuf = b->buf; /* save it in case we need it again */
2793 b->buf = NULL; /* Clear to trigger below */
2797 PerlIOMmap_map(f); /* Try and map it */
2800 /* Map did not work - recover PerlIOBuf buffer if we have one */
2804 b->ptr = b->end = b->buf;
2807 return PerlIOBuf_get_base(f);
2811 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2813 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2814 PerlIOBuf *b = &m->base;
2815 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2817 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2820 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2825 /* Loose the unwritable mapped buffer */
2827 /* If flush took the "buffer" see if we have one from before */
2828 if (!b->buf && m->bbuf)
2832 PerlIOBuf_get_base(f);
2836 return PerlIOBuf_unread(f,vbuf,count);
2840 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2842 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2843 PerlIOBuf *b = &m->base;
2844 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2846 /* No, or wrong sort of, buffer */
2849 if (PerlIOMmap_unmap(f) != 0)
2852 /* If unmap took the "buffer" see if we have one from before */
2853 if (!b->buf && m->bbuf)
2857 PerlIOBuf_get_base(f);
2861 return PerlIOBuf_write(f,vbuf,count);
2865 PerlIOMmap_flush(PerlIO *f)
2867 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2868 PerlIOBuf *b = &m->base;
2869 IV code = PerlIOBuf_flush(f);
2870 /* Now we are "synced" at PerlIOBuf level */
2875 /* Unmap the buffer */
2876 if (PerlIOMmap_unmap(f) != 0)
2881 /* We seem to have a PerlIOBuf buffer which was not mapped
2882 * remember it in case we need one later
2891 PerlIOMmap_fill(PerlIO *f)
2893 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2894 IV code = PerlIO_flush(f);
2895 if (code == 0 && !b->buf)
2897 code = PerlIOMmap_map(f);
2899 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2901 code = PerlIOBuf_fill(f);
2907 PerlIOMmap_close(PerlIO *f)
2909 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2910 PerlIOBuf *b = &m->base;
2911 IV code = PerlIO_flush(f);
2916 b->ptr = b->end = b->buf;
2918 if (PerlIOBuf_close(f) != 0)
2924 PerlIO_funcs PerlIO_mmap = {
2944 PerlIOBase_clearerr,
2945 PerlIOBuf_setlinebuf,
2946 PerlIOMmap_get_base,
2950 PerlIOBuf_set_ptrcnt,
2953 #endif /* HAS_MMAP */
2961 atexit(&PerlIO_cleanup);
2971 PerlIO_stdstreams();
2975 #undef PerlIO_stdout
2980 PerlIO_stdstreams();
2984 #undef PerlIO_stderr
2989 PerlIO_stdstreams();
2993 /*--------------------------------------------------------------------------------------*/
2995 #undef PerlIO_getname
2997 PerlIO_getname(PerlIO *f, char *buf)
3000 Perl_croak(aTHX_ "Don't know how to get file name");
3005 /*--------------------------------------------------------------------------------------*/
3006 /* Functions which can be called on any kind of PerlIO implemented
3012 PerlIO_getc(PerlIO *f)
3015 SSize_t count = PerlIO_read(f,buf,1);
3018 return (unsigned char) buf[0];
3023 #undef PerlIO_ungetc
3025 PerlIO_ungetc(PerlIO *f, int ch)
3030 if (PerlIO_unread(f,&buf,1) == 1)
3038 PerlIO_putc(PerlIO *f, int ch)
3041 return PerlIO_write(f,&buf,1);
3046 PerlIO_puts(PerlIO *f, const char *s)
3048 STRLEN len = strlen(s);
3049 return PerlIO_write(f,s,len);
3052 #undef PerlIO_rewind
3054 PerlIO_rewind(PerlIO *f)
3056 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3060 #undef PerlIO_vprintf
3062 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3065 SV *sv = newSVpvn("",0);
3070 Perl_va_copy(ap, apc);
3071 sv_vcatpvf(sv, fmt, &apc);
3073 sv_vcatpvf(sv, fmt, &ap);
3076 return PerlIO_write(f,s,len);
3079 #undef PerlIO_printf
3081 PerlIO_printf(PerlIO *f,const char *fmt,...)
3086 result = PerlIO_vprintf(f,fmt,ap);
3091 #undef PerlIO_stdoutf
3093 PerlIO_stdoutf(const char *fmt,...)
3098 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3103 #undef PerlIO_tmpfile
3105 PerlIO_tmpfile(void)
3107 /* I have no idea how portable mkstemp() is ... */
3108 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3111 FILE *stdio = PerlSIO_tmpfile();
3114 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
3120 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3121 int fd = mkstemp(SvPVX(sv));
3125 f = PerlIO_fdopen(fd,"w+");
3128 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3130 PerlLIO_unlink(SvPVX(sv));
3140 #endif /* USE_SFIO */
3141 #endif /* PERLIO_IS_STDIO */
3143 /*======================================================================================*/
3144 /* Now some functions in terms of above which may be needed even if
3145 we are not in true PerlIO mode
3149 #undef PerlIO_setpos
3151 PerlIO_setpos(PerlIO *f, SV *pos)
3157 Off_t *posn = (Off_t *) SvPV(pos,len);
3158 if (f && len == sizeof(Off_t))
3159 return PerlIO_seek(f,*posn,SEEK_SET);
3165 #undef PerlIO_setpos
3167 PerlIO_setpos(PerlIO *f, SV *pos)
3173 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3174 if (f && len == sizeof(Fpos_t))
3176 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3177 return fsetpos64(f, fpos);
3179 return fsetpos(f, fpos);
3189 #undef PerlIO_getpos
3191 PerlIO_getpos(PerlIO *f, SV *pos)
3194 Off_t posn = PerlIO_tell(f);
3195 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3196 return (posn == (Off_t)-1) ? -1 : 0;
3199 #undef PerlIO_getpos
3201 PerlIO_getpos(PerlIO *f, SV *pos)
3206 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3207 code = fgetpos64(f, &fpos);
3209 code = fgetpos(f, &fpos);
3211 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3216 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3219 vprintf(char *pat, char *args)
3221 _doprnt(pat, args, stdout);
3222 return 0; /* wrong, but perl doesn't use the return value */
3226 vfprintf(FILE *fd, char *pat, char *args)
3228 _doprnt(pat, args, fd);
3229 return 0; /* wrong, but perl doesn't use the return value */
3234 #ifndef PerlIO_vsprintf
3236 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3238 int val = vsprintf(s, fmt, ap);
3241 if (strlen(s) >= (STRLEN)n)
3244 (void)PerlIO_puts(Perl_error_log,
3245 "panic: sprintf overflow - memory corrupted!\n");
3253 #ifndef PerlIO_sprintf
3255 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3260 result = PerlIO_vsprintf(s, n, fmt, ap);