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)
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))
571 SV *layer = PerlIO_find_layer(s,e-s);
574 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
577 PerlIO *new = PerlIO_push(f,tab,mode);
583 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
595 /*--------------------------------------------------------------------------------------*/
596 /* Given the abstraction above the public API functions */
599 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
601 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
602 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
603 if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
609 if (PerlIOBase(top)->tab == &PerlIO_crlf)
612 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
615 top = PerlIONext(top);
618 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
623 PerlIO__close(PerlIO *f)
625 return (*PerlIOBase(f)->tab->Close)(f);
628 #undef PerlIO_fdupopen
630 PerlIO_fdupopen(pTHX_ PerlIO *f)
633 int fd = PerlLIO_dup(PerlIO_fileno(f));
634 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
637 Off_t posn = PerlIO_tell(f);
638 PerlIO_seek(new,posn,SEEK_SET);
645 PerlIO_close(PerlIO *f)
647 int code = (*PerlIOBase(f)->tab->Close)(f);
657 PerlIO_fileno(PerlIO *f)
659 return (*PerlIOBase(f)->tab->Fileno)(f);
666 PerlIO_fdopen(int fd, const char *mode)
668 PerlIO_funcs *tab = PerlIO_default_top();
671 return (*tab->Fdopen)(tab,fd,mode);
676 PerlIO_open(const char *path, const char *mode)
678 PerlIO_funcs *tab = PerlIO_default_top();
681 return (*tab->Open)(tab,path,mode);
686 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
691 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
693 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
699 return PerlIO_open(path,mode);
704 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
706 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
711 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
713 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
718 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
720 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
725 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
727 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
732 PerlIO_tell(PerlIO *f)
734 return (*PerlIOBase(f)->tab->Tell)(f);
739 PerlIO_flush(PerlIO *f)
743 return (*PerlIOBase(f)->tab->Flush)(f);
747 PerlIO **table = &_perlio;
752 table = (PerlIO **)(f++);
753 for (i=1; i < PERLIO_TABLE_SIZE; i++)
755 if (*f && PerlIO_flush(f) != 0)
766 PerlIO_fill(PerlIO *f)
768 return (*PerlIOBase(f)->tab->Fill)(f);
773 PerlIO_isutf8(PerlIO *f)
775 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
780 PerlIO_eof(PerlIO *f)
782 return (*PerlIOBase(f)->tab->Eof)(f);
787 PerlIO_error(PerlIO *f)
789 return (*PerlIOBase(f)->tab->Error)(f);
792 #undef PerlIO_clearerr
794 PerlIO_clearerr(PerlIO *f)
797 (*PerlIOBase(f)->tab->Clearerr)(f);
800 #undef PerlIO_setlinebuf
802 PerlIO_setlinebuf(PerlIO *f)
804 (*PerlIOBase(f)->tab->Setlinebuf)(f);
807 #undef PerlIO_has_base
809 PerlIO_has_base(PerlIO *f)
813 return (PerlIOBase(f)->tab->Get_base != NULL);
818 #undef PerlIO_fast_gets
820 PerlIO_fast_gets(PerlIO *f)
822 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
824 PerlIO_funcs *tab = PerlIOBase(f)->tab;
825 return (tab->Set_ptrcnt != NULL);
830 #undef PerlIO_has_cntptr
832 PerlIO_has_cntptr(PerlIO *f)
836 PerlIO_funcs *tab = PerlIOBase(f)->tab;
837 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
842 #undef PerlIO_canset_cnt
844 PerlIO_canset_cnt(PerlIO *f)
848 PerlIOl *l = PerlIOBase(f);
849 return (l->tab->Set_ptrcnt != NULL);
854 #undef PerlIO_get_base
856 PerlIO_get_base(PerlIO *f)
858 return (*PerlIOBase(f)->tab->Get_base)(f);
861 #undef PerlIO_get_bufsiz
863 PerlIO_get_bufsiz(PerlIO *f)
865 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
868 #undef PerlIO_get_ptr
870 PerlIO_get_ptr(PerlIO *f)
872 PerlIO_funcs *tab = PerlIOBase(f)->tab;
873 if (tab->Get_ptr == NULL)
875 return (*tab->Get_ptr)(f);
878 #undef PerlIO_get_cnt
880 PerlIO_get_cnt(PerlIO *f)
882 PerlIO_funcs *tab = PerlIOBase(f)->tab;
883 if (tab->Get_cnt == NULL)
885 return (*tab->Get_cnt)(f);
888 #undef PerlIO_set_cnt
890 PerlIO_set_cnt(PerlIO *f,int cnt)
892 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
895 #undef PerlIO_set_ptrcnt
897 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
899 PerlIO_funcs *tab = PerlIOBase(f)->tab;
900 if (tab->Set_ptrcnt == NULL)
903 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
905 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
908 /*--------------------------------------------------------------------------------------*/
909 /* "Methods" of the "base class" */
912 PerlIOBase_fileno(PerlIO *f)
914 return PerlIO_fileno(PerlIONext(f));
918 PerlIO_modestr(PerlIO *f,char *buf)
921 IV flags = PerlIOBase(f)->flags;
922 if (flags & PERLIO_F_APPEND)
925 if (flags & PERLIO_F_CANREAD)
930 else if (flags & PERLIO_F_CANREAD)
933 if (flags & PERLIO_F_CANWRITE)
936 else if (flags & PERLIO_F_CANWRITE)
939 if (flags & PERLIO_F_CANREAD)
944 #if O_TEXT != O_BINARY
945 if (!(flags & PERLIO_F_CRLF))
953 PerlIOBase_pushed(PerlIO *f, const char *mode)
955 PerlIOl *l = PerlIOBase(f);
956 const char *omode = mode;
958 PerlIO_funcs *tab = PerlIOBase(f)->tab;
959 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
960 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
961 if (tab->Set_ptrcnt != NULL)
962 l->flags |= PERLIO_F_FASTGETS;
968 l->flags |= PERLIO_F_CANREAD;
971 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
974 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
985 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
988 l->flags &= ~PERLIO_F_CRLF;
991 l->flags |= PERLIO_F_CRLF;
1003 l->flags |= l->next->flags &
1004 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1008 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1009 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1010 l->flags,PerlIO_modestr(f,temp));
1016 PerlIOBase_popped(PerlIO *f)
1021 extern PerlIO_funcs PerlIO_pending;
1024 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1027 Off_t old = PerlIO_tell(f);
1028 if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
1030 Off_t new = PerlIO_tell(f);
1038 PerlIO_push(f,&PerlIO_pending,"r");
1039 return PerlIOBuf_unread(f,vbuf,count);
1044 PerlIOBase_noop_ok(PerlIO *f)
1050 PerlIOBase_noop_fail(PerlIO *f)
1056 PerlIOBase_close(PerlIO *f)
1059 PerlIO *n = PerlIONext(f);
1060 if (PerlIO_flush(f) != 0)
1062 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1064 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1069 PerlIOBase_eof(PerlIO *f)
1073 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1079 PerlIOBase_error(PerlIO *f)
1083 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1089 PerlIOBase_clearerr(PerlIO *f)
1093 PerlIO *n = PerlIONext(f);
1094 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1101 PerlIOBase_setlinebuf(PerlIO *f)
1106 /*--------------------------------------------------------------------------------------*/
1107 /* Bottom-most level for UNIX-like case */
1111 struct _PerlIO base; /* The generic part */
1112 int fd; /* UNIX like file descriptor */
1113 int oflags; /* open/fcntl flags */
1117 PerlIOUnix_oflags(const char *mode)
1132 oflags = O_CREAT|O_TRUNC;
1143 oflags = O_CREAT|O_APPEND;
1159 else if (*mode == 't')
1162 oflags &= ~O_BINARY;
1165 /* Always open in binary mode */
1167 if (*mode || oflags == -1)
1176 PerlIOUnix_fileno(PerlIO *f)
1178 return PerlIOSelf(f,PerlIOUnix)->fd;
1182 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1190 int oflags = PerlIOUnix_oflags(mode);
1193 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1196 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1203 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1207 int oflags = PerlIOUnix_oflags(mode);
1210 int fd = PerlLIO_open3(path,oflags,0666);
1213 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1216 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1223 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1225 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1226 int oflags = PerlIOUnix_oflags(mode);
1227 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1228 (*PerlIOBase(f)->tab->Close)(f);
1232 int fd = PerlLIO_open3(path,oflags,0666);
1237 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1245 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1248 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1249 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1253 SSize_t len = PerlLIO_read(fd,vbuf,count);
1254 if (len >= 0 || errno != EINTR)
1257 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1258 else if (len == 0 && count != 0)
1259 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1266 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1269 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1272 SSize_t len = PerlLIO_write(fd,vbuf,count);
1273 if (len >= 0 || errno != EINTR)
1276 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1283 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1286 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1287 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1288 return (new == (Off_t) -1) ? -1 : 0;
1292 PerlIOUnix_tell(PerlIO *f)
1295 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1299 PerlIOUnix_close(PerlIO *f)
1302 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1304 while (PerlLIO_close(fd) != 0)
1314 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1319 PerlIO_funcs PerlIO_unix = {
1335 PerlIOBase_noop_ok, /* flush */
1336 PerlIOBase_noop_fail, /* fill */
1339 PerlIOBase_clearerr,
1340 PerlIOBase_setlinebuf,
1341 NULL, /* get_base */
1342 NULL, /* get_bufsiz */
1345 NULL, /* set_ptrcnt */
1348 /*--------------------------------------------------------------------------------------*/
1349 /* stdio as a layer */
1353 struct _PerlIO base;
1354 FILE * stdio; /* The stream */
1358 PerlIOStdio_fileno(PerlIO *f)
1361 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1365 PerlIOStdio_mode(const char *mode,char *tmode)
1367 const char *ret = mode;
1368 if (O_BINARY != O_TEXT)
1370 ret = (const char *) tmode;
1382 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1401 stdio = PerlSIO_stdin;
1404 stdio = PerlSIO_stdout;
1407 stdio = PerlSIO_stderr;
1413 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1417 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOStdio);
1424 #undef PerlIO_importFILE
1426 PerlIO_importFILE(FILE *stdio, int fl)
1432 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+"),PerlIOStdio);
1439 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1443 FILE *stdio = PerlSIO_fopen(path,mode);
1447 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1448 (mode = PerlIOStdio_mode(mode,tmode))),
1456 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1459 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1461 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1469 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1472 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1476 STDCHAR *buf = (STDCHAR *) vbuf;
1477 /* Perl is expecting PerlIO_getc() to fill the buffer
1478 * Linux's stdio does not do that for fread()
1480 int ch = PerlSIO_fgetc(s);
1488 got = PerlSIO_fread(vbuf,1,count,s);
1493 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1496 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1497 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1501 int ch = *buf-- & 0xff;
1502 if (PerlSIO_ungetc(ch,s) != ch)
1511 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1514 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1518 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1521 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1522 return PerlSIO_fseek(stdio,offset,whence);
1526 PerlIOStdio_tell(PerlIO *f)
1529 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1530 return PerlSIO_ftell(stdio);
1534 PerlIOStdio_close(PerlIO *f)
1538 int optval, optlen = sizeof(int);
1540 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1543 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1544 PerlSIO_fclose(stdio) :
1545 close(PerlIO_fileno(f))
1547 PerlSIO_fclose(stdio)
1554 PerlIOStdio_flush(PerlIO *f)
1557 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1558 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1560 return PerlSIO_fflush(stdio);
1565 /* FIXME: This discards ungetc() and pre-read stuff which is
1566 not right if this is just a "sync" from a layer above
1567 Suspect right design is to do _this_ but not have layer above
1568 flush this layer read-to-read
1570 /* Not writeable - sync by attempting a seek */
1572 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1580 PerlIOStdio_fill(PerlIO *f)
1583 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1585 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1586 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1588 if (PerlSIO_fflush(stdio) != 0)
1591 c = PerlSIO_fgetc(stdio);
1592 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1598 PerlIOStdio_eof(PerlIO *f)
1601 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1605 PerlIOStdio_error(PerlIO *f)
1608 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1612 PerlIOStdio_clearerr(PerlIO *f)
1615 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1619 PerlIOStdio_setlinebuf(PerlIO *f)
1622 #ifdef HAS_SETLINEBUF
1623 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1625 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1631 PerlIOStdio_get_base(PerlIO *f)
1634 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1635 return PerlSIO_get_base(stdio);
1639 PerlIOStdio_get_bufsiz(PerlIO *f)
1642 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1643 return PerlSIO_get_bufsiz(stdio);
1647 #ifdef USE_STDIO_PTR
1649 PerlIOStdio_get_ptr(PerlIO *f)
1652 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1653 return PerlSIO_get_ptr(stdio);
1657 PerlIOStdio_get_cnt(PerlIO *f)
1660 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1661 return PerlSIO_get_cnt(stdio);
1665 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1668 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1671 #ifdef STDIO_PTR_LVALUE
1672 PerlSIO_set_ptr(stdio,ptr);
1673 #ifdef STDIO_PTR_LVAL_SETS_CNT
1674 if (PerlSIO_get_cnt(stdio) != (cnt))
1677 assert(PerlSIO_get_cnt(stdio) == (cnt));
1680 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1681 /* Setting ptr _does_ change cnt - we are done */
1684 #else /* STDIO_PTR_LVALUE */
1686 #endif /* STDIO_PTR_LVALUE */
1688 /* Now (or only) set cnt */
1689 #ifdef STDIO_CNT_LVALUE
1690 PerlSIO_set_cnt(stdio,cnt);
1691 #else /* STDIO_CNT_LVALUE */
1692 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1693 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1694 #else /* STDIO_PTR_LVAL_SETS_CNT */
1696 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1697 #endif /* STDIO_CNT_LVALUE */
1702 PerlIO_funcs PerlIO_stdio = {
1704 sizeof(PerlIOStdio),
1722 PerlIOStdio_clearerr,
1723 PerlIOStdio_setlinebuf,
1725 PerlIOStdio_get_base,
1726 PerlIOStdio_get_bufsiz,
1731 #ifdef USE_STDIO_PTR
1732 PerlIOStdio_get_ptr,
1733 PerlIOStdio_get_cnt,
1734 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1735 PerlIOStdio_set_ptrcnt
1736 #else /* STDIO_PTR_LVALUE */
1738 #endif /* STDIO_PTR_LVALUE */
1739 #else /* USE_STDIO_PTR */
1743 #endif /* USE_STDIO_PTR */
1746 #undef PerlIO_exportFILE
1748 PerlIO_exportFILE(PerlIO *f, int fl)
1751 /* Should really push stdio discipline when we have them */
1752 return fdopen(PerlIO_fileno(f),"r+");
1755 #undef PerlIO_findFILE
1757 PerlIO_findFILE(PerlIO *f)
1759 return PerlIO_exportFILE(f,0);
1762 #undef PerlIO_releaseFILE
1764 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1768 /*--------------------------------------------------------------------------------------*/
1769 /* perlio buffer layer */
1772 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1774 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1775 b->posn = PerlIO_tell(PerlIONext(f));
1776 return PerlIOBase_pushed(f,mode);
1780 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1783 PerlIO_funcs *tab = PerlIO_default_btm();
1791 #if O_BINARY != O_TEXT
1792 /* do something about failing setmode()? --jhi */
1793 PerlLIO_setmode(fd, O_BINARY);
1795 f = (*tab->Fdopen)(tab,fd,mode);
1798 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1799 if (init && fd == 2)
1801 /* Initial stderr is unbuffered */
1802 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1805 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1806 self->name,f,fd,mode,PerlIOBase(f)->flags);
1813 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1815 PerlIO_funcs *tab = PerlIO_default_btm();
1816 PerlIO *f = (*tab->Open)(tab,path,mode);
1819 PerlIO_push(f,self,mode);
1825 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1827 PerlIO *next = PerlIONext(f);
1828 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1830 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1834 /* This "flush" is akin to sfio's sync in that it handles files in either
1838 PerlIOBuf_flush(PerlIO *f)
1840 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1842 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1844 /* write() the buffer */
1845 STDCHAR *p = b->buf;
1847 PerlIO *n = PerlIONext(f);
1850 count = PerlIO_write(n,p,b->ptr - p);
1855 else if (count < 0 || PerlIO_error(n))
1857 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1862 b->posn += (p - b->buf);
1864 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1866 /* Note position change */
1867 b->posn += (b->ptr - b->buf);
1868 if (b->ptr < b->end)
1870 /* We did not consume all of it */
1871 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1873 b->posn = PerlIO_tell(PerlIONext(f));
1877 b->ptr = b->end = b->buf;
1878 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1879 /* FIXME: Is this right for read case ? */
1880 if (PerlIO_flush(PerlIONext(f)) != 0)
1886 PerlIOBuf_fill(PerlIO *f)
1888 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1889 PerlIO *n = PerlIONext(f);
1891 /* FIXME: doing the down-stream flush is a bad idea if it causes
1892 pre-read data in stdio buffer to be discarded
1893 but this is too simplistic - as it skips _our_ hosekeeping
1894 and breaks tell tests.
1895 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1899 if (PerlIO_flush(f) != 0)
1902 b->ptr = b->end = b->buf;
1903 if (PerlIO_fast_gets(n))
1905 /* Layer below is also buffered
1906 * We do _NOT_ want to call its ->Read() because that will loop
1907 * till it gets what we asked for which may hang on a pipe etc.
1908 * Instead take anything it has to hand, or ask it to fill _once_.
1910 avail = PerlIO_get_cnt(n);
1913 avail = PerlIO_fill(n);
1915 avail = PerlIO_get_cnt(n);
1918 if (!PerlIO_error(n) && PerlIO_eof(n))
1924 STDCHAR *ptr = PerlIO_get_ptr(n);
1925 SSize_t cnt = avail;
1926 if (avail > b->bufsiz)
1928 Copy(ptr,b->buf,avail,STDCHAR);
1929 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1934 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1939 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1941 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1944 b->end = b->buf+avail;
1945 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1950 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1952 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1953 STDCHAR *buf = (STDCHAR *) vbuf;
1958 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1962 SSize_t avail = PerlIO_get_cnt(f);
1963 SSize_t take = (count < avail) ? count : avail;
1966 STDCHAR *ptr = PerlIO_get_ptr(f);
1967 Copy(ptr,buf,take,STDCHAR);
1968 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1972 if (count > 0 && avail <= 0)
1974 if (PerlIO_fill(f) != 0)
1978 return (buf - (STDCHAR *) vbuf);
1984 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1986 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1987 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1990 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1996 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1998 avail = (b->ptr - b->buf);
2003 b->end = b->buf + avail;
2005 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2006 b->posn -= b->bufsiz;
2008 if (avail > (SSize_t) count)
2016 Copy(buf,b->ptr,avail,STDCHAR);
2020 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2027 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2029 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2030 const STDCHAR *buf = (const STDCHAR *) vbuf;
2034 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2038 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2039 if ((SSize_t) count < avail)
2041 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2042 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2062 Copy(buf,b->ptr,avail,STDCHAR);
2069 if (b->ptr >= (b->buf + b->bufsiz))
2072 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2078 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2081 if ((code = PerlIO_flush(f)) == 0)
2083 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2084 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2085 code = PerlIO_seek(PerlIONext(f),offset,whence);
2088 b->posn = PerlIO_tell(PerlIONext(f));
2095 PerlIOBuf_tell(PerlIO *f)
2097 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2098 Off_t posn = b->posn;
2100 posn += (b->ptr - b->buf);
2105 PerlIOBuf_close(PerlIO *f)
2108 IV code = PerlIOBase_close(f);
2109 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2110 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2112 PerlMemShared_free(b->buf);
2115 b->ptr = b->end = b->buf;
2116 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2121 PerlIOBuf_setlinebuf(PerlIO *f)
2125 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2130 PerlIOBuf_get_ptr(PerlIO *f)
2132 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2139 PerlIOBuf_get_cnt(PerlIO *f)
2141 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2144 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2145 return (b->end - b->ptr);
2150 PerlIOBuf_get_base(PerlIO *f)
2152 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2158 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2161 b->buf = (STDCHAR *)&b->oneword;
2162 b->bufsiz = sizeof(b->oneword);
2171 PerlIOBuf_bufsiz(PerlIO *f)
2173 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2176 return (b->end - b->buf);
2180 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2182 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2186 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2189 assert(PerlIO_get_cnt(f) == cnt);
2190 assert(b->ptr >= b->buf);
2192 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2195 PerlIO_funcs PerlIO_perlio = {
2215 PerlIOBase_clearerr,
2216 PerlIOBuf_setlinebuf,
2221 PerlIOBuf_set_ptrcnt,
2224 /*--------------------------------------------------------------------------------------*/
2225 /* Temp layer to hold unread chars when cannot do it any other way */
2228 PerlIOPending_fill(PerlIO *f)
2230 /* Should never happen */
2236 PerlIOPending_close(PerlIO *f)
2238 /* A tad tricky - flush pops us, then we close new top */
2240 return PerlIO_close(f);
2244 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2246 /* A tad tricky - flush pops us, then we seek new top */
2248 return PerlIO_seek(f,offset,whence);
2253 PerlIOPending_flush(PerlIO *f)
2255 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2256 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2259 PerlMemShared_free(b->buf);
2267 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2275 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2280 PerlIOPending_pushed(PerlIO *f,const char *mode)
2282 IV code = PerlIOBuf_pushed(f,mode);
2283 PerlIOl *l = PerlIOBase(f);
2284 /* Our PerlIO_fast_gets must match what we are pushed on,
2285 or sv_gets() etc. get muddled when it changes mid-string
2288 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2289 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2294 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2296 SSize_t avail = PerlIO_get_cnt(f);
2301 got = PerlIOBuf_read(f,vbuf,avail);
2303 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2308 PerlIO_funcs PerlIO_pending = {
2316 PerlIOPending_pushed,
2323 PerlIOPending_close,
2324 PerlIOPending_flush,
2328 PerlIOBase_clearerr,
2329 PerlIOBuf_setlinebuf,
2334 PerlIOPending_set_ptrcnt,
2339 /*--------------------------------------------------------------------------------------*/
2340 /* crlf - translation
2341 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2342 to hand back a line at a time and keeping a record of which nl we "lied" about.
2343 On write translate "\n" to CR,LF
2348 PerlIOBuf base; /* PerlIOBuf stuff */
2349 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2353 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2356 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2357 code = PerlIOBuf_pushed(f,mode);
2359 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2360 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2361 PerlIOBase(f)->flags);
2368 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2370 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2376 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2377 return PerlIOBuf_unread(f,vbuf,count);
2380 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2381 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2383 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2389 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2391 b->end = b->ptr = b->buf + b->bufsiz;
2392 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2393 b->posn -= b->bufsiz;
2395 while (count > 0 && b->ptr > b->buf)
2400 if (b->ptr - 2 >= b->buf)
2426 PerlIOCrlf_get_cnt(PerlIO *f)
2428 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2431 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2433 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2434 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2436 STDCHAR *nl = b->ptr;
2438 while (nl < b->end && *nl != 0xd)
2440 if (nl < b->end && *nl == 0xd)
2452 /* Not CR,LF but just CR */
2459 /* Blast - found CR as last char in buffer */
2462 /* They may not care, defer work as long as possible */
2463 return (nl - b->ptr);
2469 b->ptr++; /* say we have read it as far as flush() is concerned */
2470 b->buf++; /* Leave space an front of buffer */
2471 b->bufsiz--; /* Buffer is thus smaller */
2472 code = PerlIO_fill(f); /* Fetch some more */
2473 b->bufsiz++; /* Restore size for next time */
2474 b->buf--; /* Point at space */
2475 b->ptr = nl = b->buf; /* Which is what we hand off */
2476 b->posn--; /* Buffer starts here */
2477 *nl = 0xd; /* Fill in the CR */
2479 goto test; /* fill() call worked */
2480 /* CR at EOF - just fall through */
2485 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2491 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2493 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2494 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2495 IV flags = PerlIOBase(f)->flags;
2505 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2512 /* Test code - delete when it works ... */
2519 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2527 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2528 ptr, chk, flags, c->nl, b->end, cnt);
2535 /* They have taken what we lied about */
2542 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2546 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2548 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2549 return PerlIOBuf_write(f,vbuf,count);
2552 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2553 const STDCHAR *buf = (const STDCHAR *) vbuf;
2554 const STDCHAR *ebuf = buf+count;
2557 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2561 STDCHAR *eptr = b->buf+b->bufsiz;
2562 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2563 while (buf < ebuf && b->ptr < eptr)
2567 if ((b->ptr + 2) > eptr)
2569 /* Not room for both */
2575 *(b->ptr)++ = 0xd; /* CR */
2576 *(b->ptr)++ = 0xa; /* LF */
2578 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2597 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2599 return (buf - (STDCHAR *) vbuf);
2604 PerlIOCrlf_flush(PerlIO *f)
2606 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2612 return PerlIOBuf_flush(f);
2615 PerlIO_funcs PerlIO_crlf = {
2618 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2624 PerlIOBase_noop_ok, /* popped */
2625 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2626 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2627 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2635 PerlIOBase_clearerr,
2636 PerlIOBuf_setlinebuf,
2641 PerlIOCrlf_set_ptrcnt,
2645 /*--------------------------------------------------------------------------------------*/
2646 /* mmap as "buffer" layer */
2650 PerlIOBuf base; /* PerlIOBuf stuff */
2651 Mmap_t mptr; /* Mapped address */
2652 Size_t len; /* mapped length */
2653 STDCHAR *bbuf; /* malloced buffer if map fails */
2656 static size_t page_size = 0;
2659 PerlIOMmap_map(PerlIO *f)
2662 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2663 PerlIOBuf *b = &m->base;
2664 IV flags = PerlIOBase(f)->flags;
2668 if (flags & PERLIO_F_CANREAD)
2670 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2671 int fd = PerlIO_fileno(f);
2673 code = fstat(fd,&st);
2674 if (code == 0 && S_ISREG(st.st_mode))
2676 SSize_t len = st.st_size - b->posn;
2681 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2683 SETERRNO(0,SS$_NORMAL);
2684 # ifdef _SC_PAGESIZE
2685 page_size = sysconf(_SC_PAGESIZE);
2687 page_size = sysconf(_SC_PAGE_SIZE);
2689 if ((long)page_size < 0) {
2694 (void)SvUPGRADE(error, SVt_PV);
2695 msg = SvPVx(error, n_a);
2696 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2699 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2703 # ifdef HAS_GETPAGESIZE
2704 page_size = getpagesize();
2706 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2707 page_size = PAGESIZE; /* compiletime, bad */
2711 if ((IV)page_size <= 0)
2712 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2716 /* This is a hack - should never happen - open should have set it ! */
2717 b->posn = PerlIO_tell(PerlIONext(f));
2719 posn = (b->posn / page_size) * page_size;
2720 len = st.st_size - posn;
2721 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2722 if (m->mptr && m->mptr != (Mmap_t) -1)
2724 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2725 madvise(m->mptr, len, MADV_SEQUENTIAL);
2727 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2728 b->end = ((STDCHAR *)m->mptr) + len;
2729 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2740 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2742 b->ptr = b->end = b->ptr;
2751 PerlIOMmap_unmap(PerlIO *f)
2753 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2754 PerlIOBuf *b = &m->base;
2760 code = munmap(m->mptr, m->len);
2764 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2767 b->ptr = b->end = b->buf;
2768 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2774 PerlIOMmap_get_base(PerlIO *f)
2776 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2777 PerlIOBuf *b = &m->base;
2778 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2780 /* Already have a readbuffer in progress */
2785 /* We have a write buffer or flushed PerlIOBuf read buffer */
2786 m->bbuf = b->buf; /* save it in case we need it again */
2787 b->buf = NULL; /* Clear to trigger below */
2791 PerlIOMmap_map(f); /* Try and map it */
2794 /* Map did not work - recover PerlIOBuf buffer if we have one */
2798 b->ptr = b->end = b->buf;
2801 return PerlIOBuf_get_base(f);
2805 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2807 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2808 PerlIOBuf *b = &m->base;
2809 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2811 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2814 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2819 /* Loose the unwritable mapped buffer */
2821 /* If flush took the "buffer" see if we have one from before */
2822 if (!b->buf && m->bbuf)
2826 PerlIOBuf_get_base(f);
2830 return PerlIOBuf_unread(f,vbuf,count);
2834 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2836 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2837 PerlIOBuf *b = &m->base;
2838 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2840 /* No, or wrong sort of, buffer */
2843 if (PerlIOMmap_unmap(f) != 0)
2846 /* If unmap took the "buffer" see if we have one from before */
2847 if (!b->buf && m->bbuf)
2851 PerlIOBuf_get_base(f);
2855 return PerlIOBuf_write(f,vbuf,count);
2859 PerlIOMmap_flush(PerlIO *f)
2861 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2862 PerlIOBuf *b = &m->base;
2863 IV code = PerlIOBuf_flush(f);
2864 /* Now we are "synced" at PerlIOBuf level */
2869 /* Unmap the buffer */
2870 if (PerlIOMmap_unmap(f) != 0)
2875 /* We seem to have a PerlIOBuf buffer which was not mapped
2876 * remember it in case we need one later
2885 PerlIOMmap_fill(PerlIO *f)
2887 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2888 IV code = PerlIO_flush(f);
2889 if (code == 0 && !b->buf)
2891 code = PerlIOMmap_map(f);
2893 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2895 code = PerlIOBuf_fill(f);
2901 PerlIOMmap_close(PerlIO *f)
2903 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2904 PerlIOBuf *b = &m->base;
2905 IV code = PerlIO_flush(f);
2910 b->ptr = b->end = b->buf;
2912 if (PerlIOBuf_close(f) != 0)
2918 PerlIO_funcs PerlIO_mmap = {
2938 PerlIOBase_clearerr,
2939 PerlIOBuf_setlinebuf,
2940 PerlIOMmap_get_base,
2944 PerlIOBuf_set_ptrcnt,
2947 #endif /* HAS_MMAP */
2954 atexit(&PerlIO_cleanup);
2963 PerlIO_stdstreams();
2967 #undef PerlIO_stdout
2972 PerlIO_stdstreams();
2976 #undef PerlIO_stderr
2981 PerlIO_stdstreams();
2985 /*--------------------------------------------------------------------------------------*/
2987 #undef PerlIO_getname
2989 PerlIO_getname(PerlIO *f, char *buf)
2992 Perl_croak(aTHX_ "Don't know how to get file name");
2997 /*--------------------------------------------------------------------------------------*/
2998 /* Functions which can be called on any kind of PerlIO implemented
3004 PerlIO_getc(PerlIO *f)
3007 SSize_t count = PerlIO_read(f,buf,1);
3010 return (unsigned char) buf[0];
3015 #undef PerlIO_ungetc
3017 PerlIO_ungetc(PerlIO *f, int ch)
3022 if (PerlIO_unread(f,&buf,1) == 1)
3030 PerlIO_putc(PerlIO *f, int ch)
3033 return PerlIO_write(f,&buf,1);
3038 PerlIO_puts(PerlIO *f, const char *s)
3040 STRLEN len = strlen(s);
3041 return PerlIO_write(f,s,len);
3044 #undef PerlIO_rewind
3046 PerlIO_rewind(PerlIO *f)
3048 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3052 #undef PerlIO_vprintf
3054 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3057 SV *sv = newSVpvn("",0);
3062 Perl_va_copy(ap, apc);
3063 sv_vcatpvf(sv, fmt, &apc);
3065 sv_vcatpvf(sv, fmt, &ap);
3068 return PerlIO_write(f,s,len);
3071 #undef PerlIO_printf
3073 PerlIO_printf(PerlIO *f,const char *fmt,...)
3078 result = PerlIO_vprintf(f,fmt,ap);
3083 #undef PerlIO_stdoutf
3085 PerlIO_stdoutf(const char *fmt,...)
3090 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3095 #undef PerlIO_tmpfile
3097 PerlIO_tmpfile(void)
3099 /* I have no idea how portable mkstemp() is ... */
3100 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3103 FILE *stdio = PerlSIO_tmpfile();
3106 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
3112 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3113 int fd = mkstemp(SvPVX(sv));
3117 f = PerlIO_fdopen(fd,"w+");
3120 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3122 PerlLIO_unlink(SvPVX(sv));
3132 #endif /* USE_SFIO */
3133 #endif /* PERLIO_IS_STDIO */
3135 /*======================================================================================*/
3136 /* Now some functions in terms of above which may be needed even if
3137 we are not in true PerlIO mode
3141 #undef PerlIO_setpos
3143 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3145 return PerlIO_seek(f,*pos,0);
3148 #ifndef PERLIO_IS_STDIO
3149 #undef PerlIO_setpos
3151 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3153 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3154 return fsetpos64(f, pos);
3156 return fsetpos(f, pos);
3163 #undef PerlIO_getpos
3165 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3167 *pos = PerlIO_tell(f);
3168 return *pos == -1 ? -1 : 0;
3171 #ifndef PERLIO_IS_STDIO
3172 #undef PerlIO_getpos
3174 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3176 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3177 return fgetpos64(f, pos);
3179 return fgetpos(f, pos);
3185 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3188 vprintf(char *pat, char *args)
3190 _doprnt(pat, args, stdout);
3191 return 0; /* wrong, but perl doesn't use the return value */
3195 vfprintf(FILE *fd, char *pat, char *args)
3197 _doprnt(pat, args, fd);
3198 return 0; /* wrong, but perl doesn't use the return value */
3203 #ifndef PerlIO_vsprintf
3205 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3207 int val = vsprintf(s, fmt, ap);
3210 if (strlen(s) >= (STRLEN)n)
3213 (void)PerlIO_puts(Perl_error_log,
3214 "panic: sprintf overflow - memory corrupted!\n");
3222 #ifndef PerlIO_sprintf
3224 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3229 result = PerlIO_vsprintf(s, n, fmt, ap);