3 * Copyright (c) 1996-2000, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
33 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
35 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
39 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
45 perlsio_binmode(FILE *fp, int iotype, int mode)
47 /* This used to be contents of do_binmode in doio.c */
49 # if defined(atarist) || defined(__MINT__)
52 ((FILE*)fp)->_flag |= _IOBIN;
54 ((FILE*)fp)->_flag &= ~ _IOBIN;
59 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
60 # if defined(WIN32) && defined(__BORLANDC__)
61 /* The translation mode of the stream is maintained independent
62 * of the translation mode of the fd in the Borland RTL (heavy
63 * digging through their runtime sources reveal). User has to
64 * set the mode explicitly for the stream (though they don't
65 * document this anywhere). GSAR 97-5-24
71 fp->flags &= ~ _F_BIN;
79 # if defined(USEMYBINMODE)
80 if (my_binmode(fp, iotype, mode) != FALSE)
91 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
93 return perlsio_binmode(fp,iotype,mode);
99 #ifdef PERLIO_IS_STDIO
104 /* Does nothing (yet) except force this file to be included
105 in perl binary. That allows this file to force inclusion
106 of other functions that may be required by loadable
107 extensions e.g. for FileHandle::tmpfile
111 #undef PerlIO_tmpfile
118 #else /* PERLIO_IS_STDIO */
125 /* This section is just to make sure these functions
126 get pulled in from libsfio.a
129 #undef PerlIO_tmpfile
139 /* Force this file to be included in perl binary. Which allows
140 * this file to force inclusion of other functions that may be
141 * required by loadable extensions e.g. for FileHandle::tmpfile
145 * sfio does its own 'autoflush' on stdout in common cases.
146 * Flush results in a lot of lseek()s to regular files and
147 * lot of small writes to pipes.
149 sfset(sfstdout,SF_SHARE,0);
153 /*======================================================================================*/
154 /* Implement all the PerlIO interface ourselves.
159 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
164 #include <sys/mman.h>
169 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
172 PerlIO_debug(const char *fmt,...)
180 char *s = PerlEnv_getenv("PERLIO_DEBUG");
182 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
189 SV *sv = newSVpvn("",0);
192 s = CopFILE(PL_curcop);
195 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
196 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
199 PerlLIO_write(dbg,s,len);
205 /*--------------------------------------------------------------------------------------*/
207 /* Inner level routines */
209 /* Table of pointers to the PerlIO structs (malloc'ed) */
210 PerlIO *_perlio = NULL;
211 #define PERLIO_TABLE_SIZE 64
214 PerlIO_allocate(pTHX)
216 /* Find a free slot in the table, allocating new table as necessary */
223 last = (PerlIO **)(f);
224 for (i=1; i < PERLIO_TABLE_SIZE; i++)
232 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
242 PerlIO_cleantable(pTHX_ PerlIO **tablep)
244 PerlIO *table = *tablep;
248 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
249 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
257 PerlMemShared_free(table);
269 PerlIO_cleantable(aTHX_ &_perlio);
273 PerlIO_pop(PerlIO *f)
279 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
280 (*l->tab->Popped)(f);
282 PerlMemShared_free(l);
286 /*--------------------------------------------------------------------------------------*/
287 /* XS Interface for perl code */
293 char *s = GvNAME(gv);
294 STRLEN l = GvNAMELEN(gv);
295 PerlIO_debug("%.*s\n",(int) l,s);
299 XS(XS_perlio_unimport)
303 char *s = GvNAME(gv);
304 STRLEN l = GvNAMELEN(gv);
305 PerlIO_debug("%.*s\n",(int) l,s);
310 PerlIO_find_layer(const char *name, STRLEN len)
315 if ((SSize_t) len <= 0)
317 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
318 if (svp && (sv = *svp) && SvROK(sv))
325 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
329 IO *io = GvIOn((GV *)SvRV(sv));
330 PerlIO *ifp = IoIFP(io);
331 PerlIO *ofp = IoOFP(io);
332 AV *av = (AV *) mg->mg_obj;
333 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
339 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
343 IO *io = GvIOn((GV *)SvRV(sv));
344 PerlIO *ifp = IoIFP(io);
345 PerlIO *ofp = IoOFP(io);
346 AV *av = (AV *) mg->mg_obj;
347 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
353 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
355 Perl_warn(aTHX_ "clear %"SVf,sv);
360 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
362 Perl_warn(aTHX_ "free %"SVf,sv);
366 MGVTBL perlio_vtab = {
374 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
377 SV *sv = SvRV(ST(1));
382 sv_magic(sv, (SV *)av, '~', NULL, 0);
384 mg = mg_find(sv,'~');
385 mg->mg_virtual = &perlio_vtab;
387 Perl_warn(aTHX_ "attrib %"SVf,sv);
388 for (i=2; i < items; i++)
391 const char *name = SvPV(ST(i),len);
392 SV *layer = PerlIO_find_layer(name,len);
395 av_push(av,SvREFCNT_inc(layer));
408 PerlIO_define_layer(PerlIO_funcs *tab)
411 HV *stash = gv_stashpv("perlio::Layer", TRUE);
412 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
413 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
417 PerlIO_default_layer(I32 n)
422 PerlIO_funcs *tab = &PerlIO_stdio;
424 if (!PerlIO_layer_hv)
426 const char *s = PerlEnv_getenv("PERLIO");
427 newXS("perlio::import",XS_perlio_import,__FILE__);
428 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
430 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
432 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
433 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
434 PerlIO_define_layer(&PerlIO_unix);
435 PerlIO_define_layer(&PerlIO_perlio);
436 PerlIO_define_layer(&PerlIO_stdio);
437 PerlIO_define_layer(&PerlIO_crlf);
439 PerlIO_define_layer(&PerlIO_mmap);
441 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
446 while (*s && isSPACE((unsigned char)*s))
452 while (*e && !isSPACE((unsigned char)*e))
456 layer = PerlIO_find_layer(s,e-s);
459 PerlIO_debug("Pushing %.*s\n",(e-s),s);
460 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
463 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
469 len = av_len(PerlIO_layer_av);
472 if (O_BINARY != O_TEXT)
474 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
478 if (PerlIO_stdio.Set_ptrcnt)
480 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
484 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
487 len = av_len(PerlIO_layer_av);
491 svp = av_fetch(PerlIO_layer_av,n,0);
492 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
494 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
496 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
500 #define PerlIO_default_top() PerlIO_default_layer(-1)
501 #define PerlIO_default_btm() PerlIO_default_layer(0)
509 PerlIO_allocate(aTHX);
510 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
511 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
512 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
517 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
521 l = PerlMemShared_calloc(tab->size,sizeof(char));
524 Zero(l,tab->size,char);
528 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
529 if ((*l->tab->Pushed)(f,mode) != 0)
539 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
543 const char *s = names;
553 while (*e && *e != ':' && !isSPACE(*e))
557 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
559 /* Pop back to bottom layer */
563 while (PerlIONext(f))
569 else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
571 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
573 else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
575 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
579 SV *layer = PerlIO_find_layer(s,e-s);
582 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
585 PerlIO *new = PerlIO_push(f,tab,mode);
591 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
603 /*--------------------------------------------------------------------------------------*/
604 /* Given the abstraction above the public API functions */
607 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
609 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
610 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
611 if (!names || (O_TEXT != O_BINARY && (mode & O_BINARY)))
617 if (PerlIOBase(top)->tab == &PerlIO_crlf)
620 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
623 top = PerlIONext(top);
626 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
631 PerlIO__close(PerlIO *f)
633 return (*PerlIOBase(f)->tab->Close)(f);
636 #undef PerlIO_fdupopen
638 PerlIO_fdupopen(pTHX_ PerlIO *f)
641 int fd = PerlLIO_dup(PerlIO_fileno(f));
642 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
645 Off_t posn = PerlIO_tell(f);
646 PerlIO_seek(new,posn,SEEK_SET);
653 PerlIO_close(PerlIO *f)
655 int code = (*PerlIOBase(f)->tab->Close)(f);
665 PerlIO_fileno(PerlIO *f)
667 return (*PerlIOBase(f)->tab->Fileno)(f);
674 PerlIO_fdopen(int fd, const char *mode)
676 PerlIO_funcs *tab = PerlIO_default_top();
679 return (*tab->Fdopen)(tab,fd,mode);
684 PerlIO_open(const char *path, const char *mode)
686 PerlIO_funcs *tab = PerlIO_default_top();
689 return (*tab->Open)(tab,path,mode);
694 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
699 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
701 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
707 return PerlIO_open(path,mode);
712 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
714 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
719 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
721 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
726 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
728 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
733 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
735 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
740 PerlIO_tell(PerlIO *f)
742 return (*PerlIOBase(f)->tab->Tell)(f);
747 PerlIO_flush(PerlIO *f)
751 return (*PerlIOBase(f)->tab->Flush)(f);
755 PerlIO **table = &_perlio;
760 table = (PerlIO **)(f++);
761 for (i=1; i < PERLIO_TABLE_SIZE; i++)
763 if (*f && PerlIO_flush(f) != 0)
774 PerlIO_fill(PerlIO *f)
776 return (*PerlIOBase(f)->tab->Fill)(f);
781 PerlIO_isutf8(PerlIO *f)
783 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
788 PerlIO_eof(PerlIO *f)
790 return (*PerlIOBase(f)->tab->Eof)(f);
795 PerlIO_error(PerlIO *f)
797 return (*PerlIOBase(f)->tab->Error)(f);
800 #undef PerlIO_clearerr
802 PerlIO_clearerr(PerlIO *f)
805 (*PerlIOBase(f)->tab->Clearerr)(f);
808 #undef PerlIO_setlinebuf
810 PerlIO_setlinebuf(PerlIO *f)
812 (*PerlIOBase(f)->tab->Setlinebuf)(f);
815 #undef PerlIO_has_base
817 PerlIO_has_base(PerlIO *f)
821 return (PerlIOBase(f)->tab->Get_base != NULL);
826 #undef PerlIO_fast_gets
828 PerlIO_fast_gets(PerlIO *f)
830 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
832 PerlIO_funcs *tab = PerlIOBase(f)->tab;
833 return (tab->Set_ptrcnt != NULL);
838 #undef PerlIO_has_cntptr
840 PerlIO_has_cntptr(PerlIO *f)
844 PerlIO_funcs *tab = PerlIOBase(f)->tab;
845 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
850 #undef PerlIO_canset_cnt
852 PerlIO_canset_cnt(PerlIO *f)
856 PerlIOl *l = PerlIOBase(f);
857 return (l->tab->Set_ptrcnt != NULL);
862 #undef PerlIO_get_base
864 PerlIO_get_base(PerlIO *f)
866 return (*PerlIOBase(f)->tab->Get_base)(f);
869 #undef PerlIO_get_bufsiz
871 PerlIO_get_bufsiz(PerlIO *f)
873 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
876 #undef PerlIO_get_ptr
878 PerlIO_get_ptr(PerlIO *f)
880 PerlIO_funcs *tab = PerlIOBase(f)->tab;
881 if (tab->Get_ptr == NULL)
883 return (*tab->Get_ptr)(f);
886 #undef PerlIO_get_cnt
888 PerlIO_get_cnt(PerlIO *f)
890 PerlIO_funcs *tab = PerlIOBase(f)->tab;
891 if (tab->Get_cnt == NULL)
893 return (*tab->Get_cnt)(f);
896 #undef PerlIO_set_cnt
898 PerlIO_set_cnt(PerlIO *f,int cnt)
900 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
903 #undef PerlIO_set_ptrcnt
905 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
907 PerlIO_funcs *tab = PerlIOBase(f)->tab;
908 if (tab->Set_ptrcnt == NULL)
911 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
913 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
916 /*--------------------------------------------------------------------------------------*/
917 /* "Methods" of the "base class" */
920 PerlIOBase_fileno(PerlIO *f)
922 return PerlIO_fileno(PerlIONext(f));
926 PerlIO_modestr(PerlIO *f,char *buf)
929 IV flags = PerlIOBase(f)->flags;
930 if (flags & PERLIO_F_APPEND)
933 if (flags & PERLIO_F_CANREAD)
938 else if (flags & PERLIO_F_CANREAD)
941 if (flags & PERLIO_F_CANWRITE)
944 else if (flags & PERLIO_F_CANWRITE)
947 if (flags & PERLIO_F_CANREAD)
952 #if O_TEXT != O_BINARY
953 if (!(flags & PERLIO_F_CRLF))
961 PerlIOBase_pushed(PerlIO *f, const char *mode)
963 PerlIOl *l = PerlIOBase(f);
964 const char *omode = mode;
966 PerlIO_funcs *tab = PerlIOBase(f)->tab;
967 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
968 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
969 if (tab->Set_ptrcnt != NULL)
970 l->flags |= PERLIO_F_FASTGETS;
976 l->flags |= PERLIO_F_CANREAD;
979 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
982 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
993 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
996 l->flags &= ~PERLIO_F_CRLF;
999 l->flags |= PERLIO_F_CRLF;
1011 l->flags |= l->next->flags &
1012 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1016 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1017 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1018 l->flags,PerlIO_modestr(f,temp));
1024 PerlIOBase_popped(PerlIO *f)
1029 extern PerlIO_funcs PerlIO_pending;
1032 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1035 Off_t old = PerlIO_tell(f);
1036 if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
1038 Off_t new = PerlIO_tell(f);
1046 PerlIO_push(f,&PerlIO_pending,"r");
1047 return PerlIOBuf_unread(f,vbuf,count);
1052 PerlIOBase_noop_ok(PerlIO *f)
1058 PerlIOBase_noop_fail(PerlIO *f)
1064 PerlIOBase_close(PerlIO *f)
1067 PerlIO *n = PerlIONext(f);
1068 if (PerlIO_flush(f) != 0)
1070 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1072 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1077 PerlIOBase_eof(PerlIO *f)
1081 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1087 PerlIOBase_error(PerlIO *f)
1091 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1097 PerlIOBase_clearerr(PerlIO *f)
1101 PerlIO *n = PerlIONext(f);
1102 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1109 PerlIOBase_setlinebuf(PerlIO *f)
1114 /*--------------------------------------------------------------------------------------*/
1115 /* Bottom-most level for UNIX-like case */
1119 struct _PerlIO base; /* The generic part */
1120 int fd; /* UNIX like file descriptor */
1121 int oflags; /* open/fcntl flags */
1125 PerlIOUnix_oflags(const char *mode)
1140 oflags = O_CREAT|O_TRUNC;
1151 oflags = O_CREAT|O_APPEND;
1167 else if (*mode == 't')
1170 oflags &= ~O_BINARY;
1173 /* Always open in binary mode */
1175 if (*mode || oflags == -1)
1184 PerlIOUnix_fileno(PerlIO *f)
1186 return PerlIOSelf(f,PerlIOUnix)->fd;
1190 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1198 int oflags = PerlIOUnix_oflags(mode);
1201 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1204 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1211 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1215 int oflags = PerlIOUnix_oflags(mode);
1218 int fd = PerlLIO_open3(path,oflags,0666);
1221 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1224 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1231 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1233 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1234 int oflags = PerlIOUnix_oflags(mode);
1235 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1236 (*PerlIOBase(f)->tab->Close)(f);
1240 int fd = PerlLIO_open3(path,oflags,0666);
1245 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1253 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1256 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1257 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1261 SSize_t len = PerlLIO_read(fd,vbuf,count);
1262 if (len >= 0 || errno != EINTR)
1265 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1266 else if (len == 0 && count != 0)
1267 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1274 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1277 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1280 SSize_t len = PerlLIO_write(fd,vbuf,count);
1281 if (len >= 0 || errno != EINTR)
1284 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1291 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1294 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1295 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1296 return (new == (Off_t) -1) ? -1 : 0;
1300 PerlIOUnix_tell(PerlIO *f)
1303 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1304 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1308 PerlIOUnix_close(PerlIO *f)
1311 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1313 while (PerlLIO_close(fd) != 0)
1323 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1328 PerlIO_funcs PerlIO_unix = {
1344 PerlIOBase_noop_ok, /* flush */
1345 PerlIOBase_noop_fail, /* fill */
1348 PerlIOBase_clearerr,
1349 PerlIOBase_setlinebuf,
1350 NULL, /* get_base */
1351 NULL, /* get_bufsiz */
1354 NULL, /* set_ptrcnt */
1357 /*--------------------------------------------------------------------------------------*/
1358 /* stdio as a layer */
1362 struct _PerlIO base;
1363 FILE * stdio; /* The stream */
1367 PerlIOStdio_fileno(PerlIO *f)
1370 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1374 PerlIOStdio_mode(const char *mode,char *tmode)
1381 if (O_BINARY != O_TEXT)
1390 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1409 stdio = PerlSIO_stdin;
1412 stdio = PerlSIO_stdout;
1415 stdio = PerlSIO_stderr;
1421 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1425 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOStdio);
1432 #undef PerlIO_importFILE
1434 PerlIO_importFILE(FILE *stdio, int fl)
1440 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+"),PerlIOStdio);
1447 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1451 FILE *stdio = PerlSIO_fopen(path,mode);
1455 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1456 (mode = PerlIOStdio_mode(mode,tmode))),
1464 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1467 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1469 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1477 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1480 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1484 STDCHAR *buf = (STDCHAR *) vbuf;
1485 /* Perl is expecting PerlIO_getc() to fill the buffer
1486 * Linux's stdio does not do that for fread()
1488 int ch = PerlSIO_fgetc(s);
1496 got = PerlSIO_fread(vbuf,1,count,s);
1501 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1504 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1505 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1509 int ch = *buf-- & 0xff;
1510 if (PerlSIO_ungetc(ch,s) != ch)
1519 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1522 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1526 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1529 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1530 return PerlSIO_fseek(stdio,offset,whence);
1534 PerlIOStdio_tell(PerlIO *f)
1537 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1538 return PerlSIO_ftell(stdio);
1542 PerlIOStdio_close(PerlIO *f)
1546 int optval, optlen = sizeof(int);
1548 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1551 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1552 PerlSIO_fclose(stdio) :
1553 close(PerlIO_fileno(f))
1555 PerlSIO_fclose(stdio)
1562 PerlIOStdio_flush(PerlIO *f)
1565 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1566 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1568 return PerlSIO_fflush(stdio);
1573 /* FIXME: This discards ungetc() and pre-read stuff which is
1574 not right if this is just a "sync" from a layer above
1575 Suspect right design is to do _this_ but not have layer above
1576 flush this layer read-to-read
1578 /* Not writeable - sync by attempting a seek */
1580 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1588 PerlIOStdio_fill(PerlIO *f)
1591 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1593 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1594 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1596 if (PerlSIO_fflush(stdio) != 0)
1599 c = PerlSIO_fgetc(stdio);
1600 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1606 PerlIOStdio_eof(PerlIO *f)
1609 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1613 PerlIOStdio_error(PerlIO *f)
1616 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1620 PerlIOStdio_clearerr(PerlIO *f)
1623 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1627 PerlIOStdio_setlinebuf(PerlIO *f)
1630 #ifdef HAS_SETLINEBUF
1631 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1633 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1639 PerlIOStdio_get_base(PerlIO *f)
1642 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1643 return PerlSIO_get_base(stdio);
1647 PerlIOStdio_get_bufsiz(PerlIO *f)
1650 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1651 return PerlSIO_get_bufsiz(stdio);
1655 #ifdef USE_STDIO_PTR
1657 PerlIOStdio_get_ptr(PerlIO *f)
1660 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1661 return PerlSIO_get_ptr(stdio);
1665 PerlIOStdio_get_cnt(PerlIO *f)
1668 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1669 return PerlSIO_get_cnt(stdio);
1673 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1676 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1679 #ifdef STDIO_PTR_LVALUE
1680 PerlSIO_set_ptr(stdio,ptr);
1681 #ifdef STDIO_PTR_LVAL_SETS_CNT
1682 if (PerlSIO_get_cnt(stdio) != (cnt))
1685 assert(PerlSIO_get_cnt(stdio) == (cnt));
1688 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1689 /* Setting ptr _does_ change cnt - we are done */
1692 #else /* STDIO_PTR_LVALUE */
1694 #endif /* STDIO_PTR_LVALUE */
1696 /* Now (or only) set cnt */
1697 #ifdef STDIO_CNT_LVALUE
1698 PerlSIO_set_cnt(stdio,cnt);
1699 #else /* STDIO_CNT_LVALUE */
1700 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1701 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1702 #else /* STDIO_PTR_LVAL_SETS_CNT */
1704 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1705 #endif /* STDIO_CNT_LVALUE */
1710 PerlIO_funcs PerlIO_stdio = {
1712 sizeof(PerlIOStdio),
1730 PerlIOStdio_clearerr,
1731 PerlIOStdio_setlinebuf,
1733 PerlIOStdio_get_base,
1734 PerlIOStdio_get_bufsiz,
1739 #ifdef USE_STDIO_PTR
1740 PerlIOStdio_get_ptr,
1741 PerlIOStdio_get_cnt,
1742 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1743 PerlIOStdio_set_ptrcnt
1744 #else /* STDIO_PTR_LVALUE */
1746 #endif /* STDIO_PTR_LVALUE */
1747 #else /* USE_STDIO_PTR */
1751 #endif /* USE_STDIO_PTR */
1754 #undef PerlIO_exportFILE
1756 PerlIO_exportFILE(PerlIO *f, int fl)
1759 /* Should really push stdio discipline when we have them */
1760 return fdopen(PerlIO_fileno(f),"r+");
1763 #undef PerlIO_findFILE
1765 PerlIO_findFILE(PerlIO *f)
1767 return PerlIO_exportFILE(f,0);
1770 #undef PerlIO_releaseFILE
1772 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1776 /*--------------------------------------------------------------------------------------*/
1777 /* perlio buffer layer */
1780 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1782 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1783 b->posn = PerlIO_tell(PerlIONext(f));
1784 return PerlIOBase_pushed(f,mode);
1788 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1791 PerlIO_funcs *tab = PerlIO_default_btm();
1799 #if O_BINARY != O_TEXT
1800 /* do something about failing setmode()? --jhi */
1801 PerlLIO_setmode(fd, O_BINARY);
1803 f = (*tab->Fdopen)(tab,fd,mode);
1806 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1807 if (init && fd == 2)
1809 /* Initial stderr is unbuffered */
1810 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1813 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1814 self->name,f,fd,mode,PerlIOBase(f)->flags);
1821 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1823 PerlIO_funcs *tab = PerlIO_default_btm();
1824 PerlIO *f = (*tab->Open)(tab,path,mode);
1827 PerlIO_push(f,self,mode);
1833 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1835 PerlIO *next = PerlIONext(f);
1836 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1838 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1842 /* This "flush" is akin to sfio's sync in that it handles files in either
1846 PerlIOBuf_flush(PerlIO *f)
1848 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1850 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1852 /* write() the buffer */
1853 STDCHAR *p = b->buf;
1855 PerlIO *n = PerlIONext(f);
1858 count = PerlIO_write(n,p,b->ptr - p);
1863 else if (count < 0 || PerlIO_error(n))
1865 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1870 b->posn += (p - b->buf);
1872 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1874 /* Note position change */
1875 b->posn += (b->ptr - b->buf);
1876 if (b->ptr < b->end)
1878 /* We did not consume all of it */
1879 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1881 b->posn = PerlIO_tell(PerlIONext(f));
1885 b->ptr = b->end = b->buf;
1886 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1887 /* FIXME: Is this right for read case ? */
1888 if (PerlIO_flush(PerlIONext(f)) != 0)
1894 PerlIOBuf_fill(PerlIO *f)
1896 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1897 PerlIO *n = PerlIONext(f);
1899 /* FIXME: doing the down-stream flush is a bad idea if it causes
1900 pre-read data in stdio buffer to be discarded
1901 but this is too simplistic - as it skips _our_ hosekeeping
1902 and breaks tell tests.
1903 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1907 if (PerlIO_flush(f) != 0)
1910 b->ptr = b->end = b->buf;
1911 if (PerlIO_fast_gets(n))
1913 /* Layer below is also buffered
1914 * We do _NOT_ want to call its ->Read() because that will loop
1915 * till it gets what we asked for which may hang on a pipe etc.
1916 * Instead take anything it has to hand, or ask it to fill _once_.
1918 avail = PerlIO_get_cnt(n);
1921 avail = PerlIO_fill(n);
1923 avail = PerlIO_get_cnt(n);
1926 if (!PerlIO_error(n) && PerlIO_eof(n))
1932 STDCHAR *ptr = PerlIO_get_ptr(n);
1933 SSize_t cnt = avail;
1934 if (avail > b->bufsiz)
1936 Copy(ptr,b->buf,avail,STDCHAR);
1937 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1942 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1947 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1949 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1952 b->end = b->buf+avail;
1953 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1958 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1960 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1961 STDCHAR *buf = (STDCHAR *) vbuf;
1966 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1970 SSize_t avail = PerlIO_get_cnt(f);
1971 SSize_t take = (count < avail) ? count : avail;
1974 STDCHAR *ptr = PerlIO_get_ptr(f);
1975 Copy(ptr,buf,take,STDCHAR);
1976 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1980 if (count > 0 && avail <= 0)
1982 if (PerlIO_fill(f) != 0)
1986 return (buf - (STDCHAR *) vbuf);
1992 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1994 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1995 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1998 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2004 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2006 avail = (b->ptr - b->buf);
2011 b->end = b->buf + avail;
2013 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2014 b->posn -= b->bufsiz;
2016 if (avail > (SSize_t) count)
2024 Copy(buf,b->ptr,avail,STDCHAR);
2028 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2035 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2037 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2038 const STDCHAR *buf = (const STDCHAR *) vbuf;
2042 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2046 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2047 if ((SSize_t) count < avail)
2049 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2050 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2070 Copy(buf,b->ptr,avail,STDCHAR);
2077 if (b->ptr >= (b->buf + b->bufsiz))
2080 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2086 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2089 if ((code = PerlIO_flush(f)) == 0)
2091 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2092 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2093 code = PerlIO_seek(PerlIONext(f),offset,whence);
2096 b->posn = PerlIO_tell(PerlIONext(f));
2103 PerlIOBuf_tell(PerlIO *f)
2105 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2106 Off_t posn = b->posn;
2108 posn += (b->ptr - b->buf);
2113 PerlIOBuf_close(PerlIO *f)
2116 IV code = PerlIOBase_close(f);
2117 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2118 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2120 PerlMemShared_free(b->buf);
2123 b->ptr = b->end = b->buf;
2124 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2129 PerlIOBuf_setlinebuf(PerlIO *f)
2133 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2138 PerlIOBuf_get_ptr(PerlIO *f)
2140 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2147 PerlIOBuf_get_cnt(PerlIO *f)
2149 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2152 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2153 return (b->end - b->ptr);
2158 PerlIOBuf_get_base(PerlIO *f)
2160 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2166 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2169 b->buf = (STDCHAR *)&b->oneword;
2170 b->bufsiz = sizeof(b->oneword);
2179 PerlIOBuf_bufsiz(PerlIO *f)
2181 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2184 return (b->end - b->buf);
2188 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2190 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2194 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2197 assert(PerlIO_get_cnt(f) == cnt);
2198 assert(b->ptr >= b->buf);
2200 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2203 PerlIO_funcs PerlIO_perlio = {
2223 PerlIOBase_clearerr,
2224 PerlIOBuf_setlinebuf,
2229 PerlIOBuf_set_ptrcnt,
2232 /*--------------------------------------------------------------------------------------*/
2233 /* Temp layer to hold unread chars when cannot do it any other way */
2236 PerlIOPending_fill(PerlIO *f)
2238 /* Should never happen */
2244 PerlIOPending_close(PerlIO *f)
2246 /* A tad tricky - flush pops us, then we close new top */
2248 return PerlIO_close(f);
2252 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2254 /* A tad tricky - flush pops us, then we seek new top */
2256 return PerlIO_seek(f,offset,whence);
2261 PerlIOPending_flush(PerlIO *f)
2263 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2264 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2267 PerlMemShared_free(b->buf);
2275 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2283 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2288 PerlIOPending_pushed(PerlIO *f,const char *mode)
2290 IV code = PerlIOBuf_pushed(f,mode);
2291 PerlIOl *l = PerlIOBase(f);
2292 /* Our PerlIO_fast_gets must match what we are pushed on,
2293 or sv_gets() etc. get muddled when it changes mid-string
2296 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2297 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2302 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2304 SSize_t avail = PerlIO_get_cnt(f);
2309 got = PerlIOBuf_read(f,vbuf,avail);
2311 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2316 PerlIO_funcs PerlIO_pending = {
2324 PerlIOPending_pushed,
2331 PerlIOPending_close,
2332 PerlIOPending_flush,
2336 PerlIOBase_clearerr,
2337 PerlIOBuf_setlinebuf,
2342 PerlIOPending_set_ptrcnt,
2347 /*--------------------------------------------------------------------------------------*/
2348 /* crlf - translation
2349 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2350 to hand back a line at a time and keeping a record of which nl we "lied" about.
2351 On write translate "\n" to CR,LF
2356 PerlIOBuf base; /* PerlIOBuf stuff */
2357 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2361 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2364 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2365 code = PerlIOBuf_pushed(f,mode);
2367 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2368 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2369 PerlIOBase(f)->flags);
2376 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2378 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2384 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2385 return PerlIOBuf_unread(f,vbuf,count);
2388 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2389 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2391 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2397 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2399 b->end = b->ptr = b->buf + b->bufsiz;
2400 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2401 b->posn -= b->bufsiz;
2403 while (count > 0 && b->ptr > b->buf)
2408 if (b->ptr - 2 >= b->buf)
2434 PerlIOCrlf_get_cnt(PerlIO *f)
2436 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2439 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2441 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2442 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2444 STDCHAR *nl = b->ptr;
2446 while (nl < b->end && *nl != 0xd)
2448 if (nl < b->end && *nl == 0xd)
2460 /* Not CR,LF but just CR */
2467 /* Blast - found CR as last char in buffer */
2470 /* They may not care, defer work as long as possible */
2471 return (nl - b->ptr);
2477 b->ptr++; /* say we have read it as far as flush() is concerned */
2478 b->buf++; /* Leave space an front of buffer */
2479 b->bufsiz--; /* Buffer is thus smaller */
2480 code = PerlIO_fill(f); /* Fetch some more */
2481 b->bufsiz++; /* Restore size for next time */
2482 b->buf--; /* Point at space */
2483 b->ptr = nl = b->buf; /* Which is what we hand off */
2484 b->posn--; /* Buffer starts here */
2485 *nl = 0xd; /* Fill in the CR */
2487 goto test; /* fill() call worked */
2488 /* CR at EOF - just fall through */
2493 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2499 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2501 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2502 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2503 IV flags = PerlIOBase(f)->flags;
2513 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2520 /* Test code - delete when it works ... */
2527 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2535 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2536 ptr, chk, flags, c->nl, b->end, cnt);
2543 /* They have taken what we lied about */
2550 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2554 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2556 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2557 return PerlIOBuf_write(f,vbuf,count);
2560 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2561 const STDCHAR *buf = (const STDCHAR *) vbuf;
2562 const STDCHAR *ebuf = buf+count;
2565 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2569 STDCHAR *eptr = b->buf+b->bufsiz;
2570 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2571 while (buf < ebuf && b->ptr < eptr)
2575 if ((b->ptr + 2) > eptr)
2577 /* Not room for both */
2583 *(b->ptr)++ = 0xd; /* CR */
2584 *(b->ptr)++ = 0xa; /* LF */
2586 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2605 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2607 return (buf - (STDCHAR *) vbuf);
2612 PerlIOCrlf_flush(PerlIO *f)
2614 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2620 return PerlIOBuf_flush(f);
2623 PerlIO_funcs PerlIO_crlf = {
2626 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2632 PerlIOBase_noop_ok, /* popped */
2633 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2634 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2635 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2643 PerlIOBase_clearerr,
2644 PerlIOBuf_setlinebuf,
2649 PerlIOCrlf_set_ptrcnt,
2653 /*--------------------------------------------------------------------------------------*/
2654 /* mmap as "buffer" layer */
2658 PerlIOBuf base; /* PerlIOBuf stuff */
2659 Mmap_t mptr; /* Mapped address */
2660 Size_t len; /* mapped length */
2661 STDCHAR *bbuf; /* malloced buffer if map fails */
2664 static size_t page_size = 0;
2667 PerlIOMmap_map(PerlIO *f)
2670 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2671 PerlIOBuf *b = &m->base;
2672 IV flags = PerlIOBase(f)->flags;
2676 if (flags & PERLIO_F_CANREAD)
2678 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2679 int fd = PerlIO_fileno(f);
2681 code = fstat(fd,&st);
2682 if (code == 0 && S_ISREG(st.st_mode))
2684 SSize_t len = st.st_size - b->posn;
2689 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2691 SETERRNO(0,SS$_NORMAL);
2692 # ifdef _SC_PAGESIZE
2693 page_size = sysconf(_SC_PAGESIZE);
2695 page_size = sysconf(_SC_PAGE_SIZE);
2697 if ((long)page_size < 0) {
2702 (void)SvUPGRADE(error, SVt_PV);
2703 msg = SvPVx(error, n_a);
2704 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2707 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2711 # ifdef HAS_GETPAGESIZE
2712 page_size = getpagesize();
2714 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2715 page_size = PAGESIZE; /* compiletime, bad */
2719 if ((IV)page_size <= 0)
2720 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2724 /* This is a hack - should never happen - open should have set it ! */
2725 b->posn = PerlIO_tell(PerlIONext(f));
2727 posn = (b->posn / page_size) * page_size;
2728 len = st.st_size - posn;
2729 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2730 if (m->mptr && m->mptr != (Mmap_t) -1)
2732 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2733 madvise(m->mptr, len, MADV_SEQUENTIAL);
2735 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2736 b->end = ((STDCHAR *)m->mptr) + len;
2737 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2748 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2750 b->ptr = b->end = b->ptr;
2759 PerlIOMmap_unmap(PerlIO *f)
2761 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2762 PerlIOBuf *b = &m->base;
2768 code = munmap(m->mptr, m->len);
2772 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2775 b->ptr = b->end = b->buf;
2776 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2782 PerlIOMmap_get_base(PerlIO *f)
2784 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2785 PerlIOBuf *b = &m->base;
2786 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2788 /* Already have a readbuffer in progress */
2793 /* We have a write buffer or flushed PerlIOBuf read buffer */
2794 m->bbuf = b->buf; /* save it in case we need it again */
2795 b->buf = NULL; /* Clear to trigger below */
2799 PerlIOMmap_map(f); /* Try and map it */
2802 /* Map did not work - recover PerlIOBuf buffer if we have one */
2806 b->ptr = b->end = b->buf;
2809 return PerlIOBuf_get_base(f);
2813 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2815 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2816 PerlIOBuf *b = &m->base;
2817 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2819 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2822 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2827 /* Loose the unwritable mapped buffer */
2829 /* If flush took the "buffer" see if we have one from before */
2830 if (!b->buf && m->bbuf)
2834 PerlIOBuf_get_base(f);
2838 return PerlIOBuf_unread(f,vbuf,count);
2842 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2844 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2845 PerlIOBuf *b = &m->base;
2846 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2848 /* No, or wrong sort of, buffer */
2851 if (PerlIOMmap_unmap(f) != 0)
2854 /* If unmap took the "buffer" see if we have one from before */
2855 if (!b->buf && m->bbuf)
2859 PerlIOBuf_get_base(f);
2863 return PerlIOBuf_write(f,vbuf,count);
2867 PerlIOMmap_flush(PerlIO *f)
2869 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2870 PerlIOBuf *b = &m->base;
2871 IV code = PerlIOBuf_flush(f);
2872 /* Now we are "synced" at PerlIOBuf level */
2877 /* Unmap the buffer */
2878 if (PerlIOMmap_unmap(f) != 0)
2883 /* We seem to have a PerlIOBuf buffer which was not mapped
2884 * remember it in case we need one later
2893 PerlIOMmap_fill(PerlIO *f)
2895 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2896 IV code = PerlIO_flush(f);
2897 if (code == 0 && !b->buf)
2899 code = PerlIOMmap_map(f);
2901 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2903 code = PerlIOBuf_fill(f);
2909 PerlIOMmap_close(PerlIO *f)
2911 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2912 PerlIOBuf *b = &m->base;
2913 IV code = PerlIO_flush(f);
2918 b->ptr = b->end = b->buf;
2920 if (PerlIOBuf_close(f) != 0)
2926 PerlIO_funcs PerlIO_mmap = {
2946 PerlIOBase_clearerr,
2947 PerlIOBuf_setlinebuf,
2948 PerlIOMmap_get_base,
2952 PerlIOBuf_set_ptrcnt,
2955 #endif /* HAS_MMAP */
2963 atexit(&PerlIO_cleanup);
2973 PerlIO_stdstreams();
2977 #undef PerlIO_stdout
2982 PerlIO_stdstreams();
2986 #undef PerlIO_stderr
2991 PerlIO_stdstreams();
2995 /*--------------------------------------------------------------------------------------*/
2997 #undef PerlIO_getname
2999 PerlIO_getname(PerlIO *f, char *buf)
3002 Perl_croak(aTHX_ "Don't know how to get file name");
3007 /*--------------------------------------------------------------------------------------*/
3008 /* Functions which can be called on any kind of PerlIO implemented
3014 PerlIO_getc(PerlIO *f)
3017 SSize_t count = PerlIO_read(f,buf,1);
3020 return (unsigned char) buf[0];
3025 #undef PerlIO_ungetc
3027 PerlIO_ungetc(PerlIO *f, int ch)
3032 if (PerlIO_unread(f,&buf,1) == 1)
3040 PerlIO_putc(PerlIO *f, int ch)
3043 return PerlIO_write(f,&buf,1);
3048 PerlIO_puts(PerlIO *f, const char *s)
3050 STRLEN len = strlen(s);
3051 return PerlIO_write(f,s,len);
3054 #undef PerlIO_rewind
3056 PerlIO_rewind(PerlIO *f)
3058 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3062 #undef PerlIO_vprintf
3064 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3067 SV *sv = newSVpvn("",0);
3072 Perl_va_copy(ap, apc);
3073 sv_vcatpvf(sv, fmt, &apc);
3075 sv_vcatpvf(sv, fmt, &ap);
3078 return PerlIO_write(f,s,len);
3081 #undef PerlIO_printf
3083 PerlIO_printf(PerlIO *f,const char *fmt,...)
3088 result = PerlIO_vprintf(f,fmt,ap);
3093 #undef PerlIO_stdoutf
3095 PerlIO_stdoutf(const char *fmt,...)
3100 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3105 #undef PerlIO_tmpfile
3107 PerlIO_tmpfile(void)
3109 /* I have no idea how portable mkstemp() is ... */
3110 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3113 FILE *stdio = PerlSIO_tmpfile();
3116 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
3122 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3123 int fd = mkstemp(SvPVX(sv));
3127 f = PerlIO_fdopen(fd,"w+");
3130 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3132 PerlLIO_unlink(SvPVX(sv));
3142 #endif /* USE_SFIO */
3143 #endif /* PERLIO_IS_STDIO */
3145 /*======================================================================================*/
3146 /* Now some functions in terms of above which may be needed even if
3147 we are not in true PerlIO mode
3151 #undef PerlIO_setpos
3153 PerlIO_setpos(PerlIO *f, SV *pos)
3159 Off_t *posn = (Off_t *) SvPV(pos,len);
3160 if (f && len == sizeof(Off_t))
3161 return PerlIO_seek(f,*posn,SEEK_SET);
3167 #undef PerlIO_setpos
3169 PerlIO_setpos(PerlIO *f, SV *pos)
3175 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3176 if (f && len == sizeof(Fpos_t))
3178 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3179 return fsetpos64(f, fpos);
3181 return fsetpos(f, fpos);
3191 #undef PerlIO_getpos
3193 PerlIO_getpos(PerlIO *f, SV *pos)
3196 Off_t posn = PerlIO_tell(f);
3197 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3198 return (posn == (Off_t)-1) ? -1 : 0;
3201 #undef PerlIO_getpos
3203 PerlIO_getpos(PerlIO *f, SV *pos)
3208 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3209 code = fgetpos64(f, &fpos);
3211 code = fgetpos(f, &fpos);
3213 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3218 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3221 vprintf(char *pat, char *args)
3223 _doprnt(pat, args, stdout);
3224 return 0; /* wrong, but perl doesn't use the return value */
3228 vfprintf(FILE *fd, char *pat, char *args)
3230 _doprnt(pat, args, fd);
3231 return 0; /* wrong, but perl doesn't use the return value */
3236 #ifndef PerlIO_vsprintf
3238 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3240 int val = vsprintf(s, fmt, ap);
3243 if (strlen(s) >= (STRLEN)n)
3246 (void)PerlIO_puts(Perl_error_log,
3247 "panic: sprintf overflow - memory corrupted!\n");
3255 #ifndef PerlIO_sprintf
3257 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3262 result = PerlIO_vsprintf(s, n, fmt, ap);