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);
98 #if !defined(PERL_IMPLICIT_SYS)
100 #ifdef PERLIO_IS_STDIO
105 /* Does nothing (yet) except force this file to be included
106 in perl binary. That allows this file to force inclusion
107 of other functions that may be required by loadable
108 extensions e.g. for FileHandle::tmpfile
112 #undef PerlIO_tmpfile
119 #else /* PERLIO_IS_STDIO */
126 /* This section is just to make sure these functions
127 get pulled in from libsfio.a
130 #undef PerlIO_tmpfile
140 /* Force this file to be included in perl binary. Which allows
141 * this file to force inclusion of other functions that may be
142 * required by loadable extensions e.g. for FileHandle::tmpfile
146 * sfio does its own 'autoflush' on stdout in common cases.
147 * Flush results in a lot of lseek()s to regular files and
148 * lot of small writes to pipes.
150 sfset(sfstdout,SF_SHARE,0);
154 /*======================================================================================*/
155 /* Implement all the PerlIO interface ourselves.
160 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
165 #include <sys/mman.h>
170 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
173 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(void)
216 /* Find a free slot in the table, allocating new table as necessary */
217 PerlIO **last = &_perlio;
222 last = (PerlIO **)(f);
223 for (i=1; i < PERLIO_TABLE_SIZE; i++)
231 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
239 PerlIO_cleantable(PerlIO **tablep)
241 PerlIO *table = *tablep;
245 PerlIO_cleantable((PerlIO **) &(table[0]));
246 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
265 PerlIO_cleantable(&_perlio);
269 PerlIO_pop(PerlIO *f)
274 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
275 (*l->tab->Popped)(f);
281 /*--------------------------------------------------------------------------------------*/
282 /* XS Interface for perl code */
288 char *s = GvNAME(gv);
289 STRLEN l = GvNAMELEN(gv);
290 PerlIO_debug("%.*s\n",(int) l,s);
294 XS(XS_perlio_unimport)
298 char *s = GvNAME(gv);
299 STRLEN l = GvNAMELEN(gv);
300 PerlIO_debug("%.*s\n",(int) l,s);
305 PerlIO_find_layer(const char *name, STRLEN len)
312 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
313 if (svp && (sv = *svp) && SvROK(sv))
320 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
324 IO *io = GvIOn((GV *)SvRV(sv));
325 PerlIO *ifp = IoIFP(io);
326 PerlIO *ofp = IoOFP(io);
327 AV *av = (AV *) mg->mg_obj;
328 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
334 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
338 IO *io = GvIOn((GV *)SvRV(sv));
339 PerlIO *ifp = IoIFP(io);
340 PerlIO *ofp = IoOFP(io);
341 AV *av = (AV *) mg->mg_obj;
342 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
348 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
350 Perl_warn(aTHX_ "clear %"SVf,sv);
355 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
357 Perl_warn(aTHX_ "free %"SVf,sv);
361 MGVTBL perlio_vtab = {
369 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
372 SV *sv = SvRV(ST(1));
377 sv_magic(sv, (SV *)av, '~', NULL, 0);
379 mg = mg_find(sv,'~');
380 mg->mg_virtual = &perlio_vtab;
382 Perl_warn(aTHX_ "attrib %"SVf,sv);
383 for (i=2; i < items; i++)
386 const char *name = SvPV(ST(i),len);
387 SV *layer = PerlIO_find_layer(name,len);
390 av_push(av,SvREFCNT_inc(layer));
403 PerlIO_define_layer(PerlIO_funcs *tab)
406 HV *stash = gv_stashpv("perlio::Layer", TRUE);
407 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
408 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
412 PerlIO_default_layer(I32 n)
417 PerlIO_funcs *tab = &PerlIO_stdio;
419 if (!PerlIO_layer_hv)
421 const char *s = PerlEnv_getenv("PERLIO");
422 newXS("perlio::import",XS_perlio_import,__FILE__);
423 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
425 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
427 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
428 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
429 PerlIO_define_layer(&PerlIO_unix);
430 PerlIO_define_layer(&PerlIO_perlio);
431 PerlIO_define_layer(&PerlIO_stdio);
432 PerlIO_define_layer(&PerlIO_crlf);
434 PerlIO_define_layer(&PerlIO_mmap);
436 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
441 while (*s && isSPACE((unsigned char)*s))
447 while (*e && !isSPACE((unsigned char)*e))
451 layer = PerlIO_find_layer(s,e-s);
454 PerlIO_debug("Pushing %.*s\n",(e-s),s);
455 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
458 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
464 len = av_len(PerlIO_layer_av);
467 if (O_BINARY != O_TEXT)
469 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
473 if (PerlIO_stdio.Set_ptrcnt)
475 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
479 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
482 len = av_len(PerlIO_layer_av);
486 svp = av_fetch(PerlIO_layer_av,n,0);
487 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
489 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
491 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
495 #define PerlIO_default_top() PerlIO_default_layer(-1)
496 #define PerlIO_default_btm() PerlIO_default_layer(0)
504 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
505 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
506 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
511 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
514 Newc('L',l,tab->size,char,PerlIOl);
517 Zero(l,tab->size,char);
521 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
522 if ((*l->tab->Pushed)(f,mode) != 0)
532 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
536 const char *s = names;
546 while (*e && *e != ':' && !isSPACE(*e))
550 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
552 /* Pop back to bottom layer */
556 while (PerlIONext(f))
564 SV *layer = PerlIO_find_layer(s,e-s);
567 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
570 PerlIO *new = PerlIO_push(f,tab,mode);
576 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
588 /*--------------------------------------------------------------------------------------*/
589 /* Given the abstraction above the public API functions */
592 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
594 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
595 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
596 if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
602 if (PerlIOBase(top)->tab == &PerlIO_crlf)
605 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
608 top = PerlIONext(top);
611 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
616 PerlIO__close(PerlIO *f)
618 return (*PerlIOBase(f)->tab->Close)(f);
624 PerlIO_close(PerlIO *f)
626 int code = (*PerlIOBase(f)->tab->Close)(f);
636 PerlIO_fileno(PerlIO *f)
638 return (*PerlIOBase(f)->tab->Fileno)(f);
645 PerlIO_fdopen(int fd, const char *mode)
647 PerlIO_funcs *tab = PerlIO_default_top();
650 return (*tab->Fdopen)(tab,fd,mode);
655 PerlIO_open(const char *path, const char *mode)
657 PerlIO_funcs *tab = PerlIO_default_top();
660 return (*tab->Open)(tab,path,mode);
665 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
670 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
672 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
678 return PerlIO_open(path,mode);
683 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
685 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
690 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
692 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
697 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
699 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
704 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
706 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
711 PerlIO_tell(PerlIO *f)
713 return (*PerlIOBase(f)->tab->Tell)(f);
718 PerlIO_flush(PerlIO *f)
722 return (*PerlIOBase(f)->tab->Flush)(f);
726 PerlIO **table = &_perlio;
731 table = (PerlIO **)(f++);
732 for (i=1; i < PERLIO_TABLE_SIZE; i++)
734 if (*f && PerlIO_flush(f) != 0)
745 PerlIO_fill(PerlIO *f)
747 return (*PerlIOBase(f)->tab->Fill)(f);
752 PerlIO_isutf8(PerlIO *f)
754 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
759 PerlIO_eof(PerlIO *f)
761 return (*PerlIOBase(f)->tab->Eof)(f);
766 PerlIO_error(PerlIO *f)
768 return (*PerlIOBase(f)->tab->Error)(f);
771 #undef PerlIO_clearerr
773 PerlIO_clearerr(PerlIO *f)
776 (*PerlIOBase(f)->tab->Clearerr)(f);
779 #undef PerlIO_setlinebuf
781 PerlIO_setlinebuf(PerlIO *f)
783 (*PerlIOBase(f)->tab->Setlinebuf)(f);
786 #undef PerlIO_has_base
788 PerlIO_has_base(PerlIO *f)
792 return (PerlIOBase(f)->tab->Get_base != NULL);
797 #undef PerlIO_fast_gets
799 PerlIO_fast_gets(PerlIO *f)
801 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
803 PerlIO_funcs *tab = PerlIOBase(f)->tab;
804 return (tab->Set_ptrcnt != NULL);
809 #undef PerlIO_has_cntptr
811 PerlIO_has_cntptr(PerlIO *f)
815 PerlIO_funcs *tab = PerlIOBase(f)->tab;
816 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
821 #undef PerlIO_canset_cnt
823 PerlIO_canset_cnt(PerlIO *f)
827 PerlIOl *l = PerlIOBase(f);
828 return (l->tab->Set_ptrcnt != NULL);
833 #undef PerlIO_get_base
835 PerlIO_get_base(PerlIO *f)
837 return (*PerlIOBase(f)->tab->Get_base)(f);
840 #undef PerlIO_get_bufsiz
842 PerlIO_get_bufsiz(PerlIO *f)
844 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
847 #undef PerlIO_get_ptr
849 PerlIO_get_ptr(PerlIO *f)
851 PerlIO_funcs *tab = PerlIOBase(f)->tab;
852 if (tab->Get_ptr == NULL)
854 return (*tab->Get_ptr)(f);
857 #undef PerlIO_get_cnt
859 PerlIO_get_cnt(PerlIO *f)
861 PerlIO_funcs *tab = PerlIOBase(f)->tab;
862 if (tab->Get_cnt == NULL)
864 return (*tab->Get_cnt)(f);
867 #undef PerlIO_set_cnt
869 PerlIO_set_cnt(PerlIO *f,int cnt)
871 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
874 #undef PerlIO_set_ptrcnt
876 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
878 PerlIO_funcs *tab = PerlIOBase(f)->tab;
879 if (tab->Set_ptrcnt == NULL)
882 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
884 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
887 /*--------------------------------------------------------------------------------------*/
888 /* "Methods" of the "base class" */
891 PerlIOBase_fileno(PerlIO *f)
893 return PerlIO_fileno(PerlIONext(f));
897 PerlIO_modestr(PerlIO *f,char *buf)
900 IV flags = PerlIOBase(f)->flags;
901 if (flags & PERLIO_F_CANREAD)
903 if (flags & PERLIO_F_CANWRITE)
905 if (flags & PERLIO_F_CRLF)
914 PerlIOBase_pushed(PerlIO *f, const char *mode)
916 PerlIOl *l = PerlIOBase(f);
917 const char *omode = mode;
919 PerlIO_funcs *tab = PerlIOBase(f)->tab;
920 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
921 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
922 if (tab->Set_ptrcnt != NULL)
923 l->flags |= PERLIO_F_FASTGETS;
929 l->flags |= PERLIO_F_CANREAD;
932 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
935 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
946 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
949 l->flags &= ~PERLIO_F_CRLF;
952 l->flags |= PERLIO_F_CRLF;
964 l->flags |= l->next->flags &
965 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
969 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
970 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
971 l->flags,PerlIO_modestr(f,temp));
977 PerlIOBase_popped(PerlIO *f)
982 extern PerlIO_funcs PerlIO_pending;
985 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
988 Off_t old = PerlIO_tell(f);
989 if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
991 Off_t new = PerlIO_tell(f);
999 PerlIO_push(f,&PerlIO_pending,"r");
1000 return PerlIOBuf_unread(f,vbuf,count);
1005 PerlIOBase_noop_ok(PerlIO *f)
1011 PerlIOBase_noop_fail(PerlIO *f)
1017 PerlIOBase_close(PerlIO *f)
1020 PerlIO *n = PerlIONext(f);
1021 if (PerlIO_flush(f) != 0)
1023 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1025 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1030 PerlIOBase_eof(PerlIO *f)
1034 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1040 PerlIOBase_error(PerlIO *f)
1044 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1050 PerlIOBase_clearerr(PerlIO *f)
1054 PerlIO *n = PerlIONext(f);
1055 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1062 PerlIOBase_setlinebuf(PerlIO *f)
1067 /*--------------------------------------------------------------------------------------*/
1068 /* Bottom-most level for UNIX-like case */
1072 struct _PerlIO base; /* The generic part */
1073 int fd; /* UNIX like file descriptor */
1074 int oflags; /* open/fcntl flags */
1078 PerlIOUnix_oflags(const char *mode)
1093 oflags = O_CREAT|O_TRUNC;
1104 oflags = O_CREAT|O_APPEND;
1120 else if (*mode == 't')
1123 oflags &= ~O_BINARY;
1126 /* Always open in binary mode */
1128 if (*mode || oflags == -1)
1137 PerlIOUnix_fileno(PerlIO *f)
1139 return PerlIOSelf(f,PerlIOUnix)->fd;
1143 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1150 int oflags = PerlIOUnix_oflags(mode);
1153 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1156 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1163 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1166 int oflags = PerlIOUnix_oflags(mode);
1169 int fd = PerlLIO_open3(path,oflags,0666);
1172 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1175 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1182 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1184 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1185 int oflags = PerlIOUnix_oflags(mode);
1186 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1187 (*PerlIOBase(f)->tab->Close)(f);
1190 int fd = PerlLIO_open3(path,oflags,0666);
1195 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1203 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1205 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1206 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1210 SSize_t len = PerlLIO_read(fd,vbuf,count);
1211 if (len >= 0 || errno != EINTR)
1214 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1215 else if (len == 0 && count != 0)
1216 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1223 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1225 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1228 SSize_t len = PerlLIO_write(fd,vbuf,count);
1229 if (len >= 0 || errno != EINTR)
1232 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1239 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1241 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1242 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1243 return (new == (Off_t) -1) ? -1 : 0;
1247 PerlIOUnix_tell(PerlIO *f)
1249 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1253 PerlIOUnix_close(PerlIO *f)
1255 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1257 while (PerlLIO_close(fd) != 0)
1267 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1272 PerlIO_funcs PerlIO_unix = {
1288 PerlIOBase_noop_ok, /* flush */
1289 PerlIOBase_noop_fail, /* fill */
1292 PerlIOBase_clearerr,
1293 PerlIOBase_setlinebuf,
1294 NULL, /* get_base */
1295 NULL, /* get_bufsiz */
1298 NULL, /* set_ptrcnt */
1301 /*--------------------------------------------------------------------------------------*/
1302 /* stdio as a layer */
1306 struct _PerlIO base;
1307 FILE * stdio; /* The stream */
1311 PerlIOStdio_fileno(PerlIO *f)
1313 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1317 PerlIOStdio_mode(const char *mode,char *tmode)
1319 const char *ret = mode;
1320 if (O_BINARY != O_TEXT)
1322 ret = (const char *) tmode;
1334 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1352 stdio = PerlSIO_stdin;
1355 stdio = PerlSIO_stdout;
1358 stdio = PerlSIO_stderr;
1364 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1368 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1375 #undef PerlIO_importFILE
1377 PerlIO_importFILE(FILE *stdio, int fl)
1382 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1389 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1392 FILE *stdio = PerlSIO_fopen(path,mode);
1396 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
1397 (mode = PerlIOStdio_mode(mode,tmode))),
1405 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1407 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1409 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1417 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1419 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1423 STDCHAR *buf = (STDCHAR *) vbuf;
1424 /* Perl is expecting PerlIO_getc() to fill the buffer
1425 * Linux's stdio does not do that for fread()
1427 int ch = PerlSIO_fgetc(s);
1435 got = PerlSIO_fread(vbuf,1,count,s);
1440 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1442 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1443 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1447 int ch = *buf-- & 0xff;
1448 if (PerlSIO_ungetc(ch,s) != ch)
1457 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1459 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1463 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1465 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1466 return PerlSIO_fseek(stdio,offset,whence);
1470 PerlIOStdio_tell(PerlIO *f)
1472 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1473 return PerlSIO_ftell(stdio);
1477 PerlIOStdio_close(PerlIO *f)
1479 int optval, optlen = sizeof(int);
1480 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1482 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1483 PerlSIO_fclose(stdio) :
1484 close(PerlIO_fileno(f)));
1488 PerlIOStdio_flush(PerlIO *f)
1490 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1491 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1493 return PerlSIO_fflush(stdio);
1498 /* FIXME: This discards ungetc() and pre-read stuff which is
1499 not right if this is just a "sync" from a layer above
1500 Suspect right design is to do _this_ but not have layer above
1501 flush this layer read-to-read
1503 /* Not writeable - sync by attempting a seek */
1505 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1513 PerlIOStdio_fill(PerlIO *f)
1515 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1517 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1518 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1520 if (PerlSIO_fflush(stdio) != 0)
1523 c = PerlSIO_fgetc(stdio);
1524 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1530 PerlIOStdio_eof(PerlIO *f)
1532 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1536 PerlIOStdio_error(PerlIO *f)
1538 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1542 PerlIOStdio_clearerr(PerlIO *f)
1544 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1548 PerlIOStdio_setlinebuf(PerlIO *f)
1550 #ifdef HAS_SETLINEBUF
1551 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1553 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1559 PerlIOStdio_get_base(PerlIO *f)
1561 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1562 return PerlSIO_get_base(stdio);
1566 PerlIOStdio_get_bufsiz(PerlIO *f)
1568 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1569 return PerlSIO_get_bufsiz(stdio);
1573 #ifdef USE_STDIO_PTR
1575 PerlIOStdio_get_ptr(PerlIO *f)
1577 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1578 return PerlSIO_get_ptr(stdio);
1582 PerlIOStdio_get_cnt(PerlIO *f)
1584 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1585 return PerlSIO_get_cnt(stdio);
1589 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1591 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1594 #ifdef STDIO_PTR_LVALUE
1595 PerlSIO_set_ptr(stdio,ptr);
1596 #ifdef STDIO_PTR_LVAL_SETS_CNT
1597 if (PerlSIO_get_cnt(stdio) != (cnt))
1600 assert(PerlSIO_get_cnt(stdio) == (cnt));
1603 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1604 /* Setting ptr _does_ change cnt - we are done */
1607 #else /* STDIO_PTR_LVALUE */
1609 #endif /* STDIO_PTR_LVALUE */
1611 /* Now (or only) set cnt */
1612 #ifdef STDIO_CNT_LVALUE
1613 PerlSIO_set_cnt(stdio,cnt);
1614 #else /* STDIO_CNT_LVALUE */
1615 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1616 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1617 #else /* STDIO_PTR_LVAL_SETS_CNT */
1619 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1620 #endif /* STDIO_CNT_LVALUE */
1625 PerlIO_funcs PerlIO_stdio = {
1627 sizeof(PerlIOStdio),
1645 PerlIOStdio_clearerr,
1646 PerlIOStdio_setlinebuf,
1648 PerlIOStdio_get_base,
1649 PerlIOStdio_get_bufsiz,
1654 #ifdef USE_STDIO_PTR
1655 PerlIOStdio_get_ptr,
1656 PerlIOStdio_get_cnt,
1657 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1658 PerlIOStdio_set_ptrcnt
1659 #else /* STDIO_PTR_LVALUE */
1661 #endif /* STDIO_PTR_LVALUE */
1662 #else /* USE_STDIO_PTR */
1666 #endif /* USE_STDIO_PTR */
1669 #undef PerlIO_exportFILE
1671 PerlIO_exportFILE(PerlIO *f, int fl)
1674 /* Should really push stdio discipline when we have them */
1675 return fdopen(PerlIO_fileno(f),"r+");
1678 #undef PerlIO_findFILE
1680 PerlIO_findFILE(PerlIO *f)
1682 return PerlIO_exportFILE(f,0);
1685 #undef PerlIO_releaseFILE
1687 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1691 /*--------------------------------------------------------------------------------------*/
1692 /* perlio buffer layer */
1695 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1697 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1698 b->posn = PerlIO_tell(PerlIONext(f));
1699 return PerlIOBase_pushed(f,mode);
1703 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1705 PerlIO_funcs *tab = PerlIO_default_btm();
1713 #if O_BINARY != O_TEXT
1714 /* do something about failing setmode()? --jhi */
1715 PerlLIO_setmode(fd, O_BINARY);
1717 f = (*tab->Fdopen)(tab,fd,mode);
1720 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1721 if (init && fd == 2)
1723 /* Initial stderr is unbuffered */
1724 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1727 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1728 self->name,f,fd,mode,PerlIOBase(f)->flags);
1735 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1737 PerlIO_funcs *tab = PerlIO_default_btm();
1738 PerlIO *f = (*tab->Open)(tab,path,mode);
1741 PerlIO_push(f,self,mode);
1747 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1749 PerlIO *next = PerlIONext(f);
1750 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1752 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1756 /* This "flush" is akin to sfio's sync in that it handles files in either
1760 PerlIOBuf_flush(PerlIO *f)
1762 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1764 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1766 /* write() the buffer */
1767 STDCHAR *p = b->buf;
1769 PerlIO *n = PerlIONext(f);
1772 count = PerlIO_write(n,p,b->ptr - p);
1777 else if (count < 0 || PerlIO_error(n))
1779 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1784 b->posn += (p - b->buf);
1786 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1788 /* Note position change */
1789 b->posn += (b->ptr - b->buf);
1790 if (b->ptr < b->end)
1792 /* We did not consume all of it */
1793 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1795 b->posn = PerlIO_tell(PerlIONext(f));
1799 b->ptr = b->end = b->buf;
1800 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1801 /* FIXME: Is this right for read case ? */
1802 if (PerlIO_flush(PerlIONext(f)) != 0)
1808 PerlIOBuf_fill(PerlIO *f)
1810 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1811 PerlIO *n = PerlIONext(f);
1813 /* FIXME: doing the down-stream flush is a bad idea if it causes
1814 pre-read data in stdio buffer to be discarded
1815 but this is too simplistic - as it skips _our_ hosekeeping
1816 and breaks tell tests.
1817 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1821 if (PerlIO_flush(f) != 0)
1824 b->ptr = b->end = b->buf;
1825 if (PerlIO_fast_gets(n))
1827 /* Layer below is also buffered
1828 * We do _NOT_ want to call its ->Read() because that will loop
1829 * till it gets what we asked for which may hang on a pipe etc.
1830 * Instead take anything it has to hand, or ask it to fill _once_.
1832 avail = PerlIO_get_cnt(n);
1835 avail = PerlIO_fill(n);
1837 avail = PerlIO_get_cnt(n);
1840 if (!PerlIO_error(n) && PerlIO_eof(n))
1846 STDCHAR *ptr = PerlIO_get_ptr(n);
1847 SSize_t cnt = avail;
1848 if (avail > b->bufsiz)
1850 Copy(ptr,b->buf,avail,STDCHAR);
1851 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1856 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1861 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1863 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1866 b->end = b->buf+avail;
1867 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1872 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1874 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1875 STDCHAR *buf = (STDCHAR *) vbuf;
1880 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1884 SSize_t avail = PerlIO_get_cnt(f);
1885 SSize_t take = (count < avail) ? count : avail;
1888 STDCHAR *ptr = PerlIO_get_ptr(f);
1889 Copy(ptr,buf,take,STDCHAR);
1890 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1894 if (count > 0 && avail <= 0)
1896 if (PerlIO_fill(f) != 0)
1900 return (buf - (STDCHAR *) vbuf);
1906 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1908 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1909 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1912 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1918 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1920 avail = (b->ptr - b->buf);
1925 b->end = b->buf + avail;
1927 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1928 b->posn -= b->bufsiz;
1930 if (avail > (SSize_t) count)
1938 Copy(buf,b->ptr,avail,STDCHAR);
1942 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1949 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1951 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1952 const STDCHAR *buf = (const STDCHAR *) vbuf;
1956 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1960 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1961 if ((SSize_t) count < avail)
1963 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1964 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1984 Copy(buf,b->ptr,avail,STDCHAR);
1991 if (b->ptr >= (b->buf + b->bufsiz))
1994 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2000 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2003 if ((code = PerlIO_flush(f)) == 0)
2005 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2006 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2007 code = PerlIO_seek(PerlIONext(f),offset,whence);
2010 b->posn = PerlIO_tell(PerlIONext(f));
2017 PerlIOBuf_tell(PerlIO *f)
2019 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2020 Off_t posn = b->posn;
2022 posn += (b->ptr - b->buf);
2027 PerlIOBuf_close(PerlIO *f)
2029 IV code = PerlIOBase_close(f);
2030 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2031 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2036 b->ptr = b->end = b->buf;
2037 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2042 PerlIOBuf_setlinebuf(PerlIO *f)
2046 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2051 PerlIOBuf_get_ptr(PerlIO *f)
2053 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2060 PerlIOBuf_get_cnt(PerlIO *f)
2062 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2065 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2066 return (b->end - b->ptr);
2071 PerlIOBuf_get_base(PerlIO *f)
2073 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2078 New('B',b->buf,b->bufsiz,STDCHAR);
2081 b->buf = (STDCHAR *)&b->oneword;
2082 b->bufsiz = sizeof(b->oneword);
2091 PerlIOBuf_bufsiz(PerlIO *f)
2093 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2096 return (b->end - b->buf);
2100 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2102 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2106 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2109 assert(PerlIO_get_cnt(f) == cnt);
2110 assert(b->ptr >= b->buf);
2112 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2115 PerlIO_funcs PerlIO_perlio = {
2135 PerlIOBase_clearerr,
2136 PerlIOBuf_setlinebuf,
2141 PerlIOBuf_set_ptrcnt,
2144 /*--------------------------------------------------------------------------------------*/
2145 /* Temp layer to hold unread chars when cannot do it any other way */
2148 PerlIOPending_fill(PerlIO *f)
2150 /* Should never happen */
2156 PerlIOPending_close(PerlIO *f)
2158 /* A tad tricky - flush pops us, then we close new top */
2160 return PerlIO_close(f);
2164 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2166 /* A tad tricky - flush pops us, then we seek new top */
2168 return PerlIO_seek(f,offset,whence);
2173 PerlIOPending_flush(PerlIO *f)
2175 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2176 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2186 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2194 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2199 PerlIOPending_pushed(PerlIO *f,const char *mode)
2201 IV code = PerlIOBuf_pushed(f,mode);
2202 PerlIOl *l = PerlIOBase(f);
2203 /* Our PerlIO_fast_gets must match what we are pushed on,
2204 or sv_gets() etc. get muddled when it changes mid-string
2207 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2208 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2213 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2215 SSize_t avail = PerlIO_get_cnt(f);
2220 got = PerlIOBuf_read(f,vbuf,avail);
2222 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2227 PerlIO_funcs PerlIO_pending = {
2235 PerlIOPending_pushed,
2242 PerlIOPending_close,
2243 PerlIOPending_flush,
2247 PerlIOBase_clearerr,
2248 PerlIOBuf_setlinebuf,
2253 PerlIOPending_set_ptrcnt,
2258 /*--------------------------------------------------------------------------------------*/
2259 /* crlf - translation
2260 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2261 to hand back a line at a time and keeping a record of which nl we "lied" about.
2262 On write translate "\n" to CR,LF
2267 PerlIOBuf base; /* PerlIOBuf stuff */
2268 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2272 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2275 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2276 code = PerlIOBuf_pushed(f,mode);
2278 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2279 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2280 PerlIOBase(f)->flags);
2287 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2289 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2295 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2296 return PerlIOBuf_unread(f,vbuf,count);
2299 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2300 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2302 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2308 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2310 b->end = b->ptr = b->buf + b->bufsiz;
2311 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2312 b->posn -= b->bufsiz;
2314 while (count > 0 && b->ptr > b->buf)
2319 if (b->ptr - 2 >= b->buf)
2345 PerlIOCrlf_get_cnt(PerlIO *f)
2347 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2350 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2352 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2353 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2355 STDCHAR *nl = b->ptr;
2357 while (nl < b->end && *nl != 0xd)
2359 if (nl < b->end && *nl == 0xd)
2371 /* Not CR,LF but just CR */
2378 /* Blast - found CR as last char in buffer */
2381 /* They may not care, defer work as long as possible */
2382 return (nl - b->ptr);
2388 b->ptr++; /* say we have read it as far as flush() is concerned */
2389 b->buf++; /* Leave space an front of buffer */
2390 b->bufsiz--; /* Buffer is thus smaller */
2391 code = PerlIO_fill(f); /* Fetch some more */
2392 b->bufsiz++; /* Restore size for next time */
2393 b->buf--; /* Point at space */
2394 b->ptr = nl = b->buf; /* Which is what we hand off */
2395 b->posn--; /* Buffer starts here */
2396 *nl = 0xd; /* Fill in the CR */
2398 goto test; /* fill() call worked */
2399 /* CR at EOF - just fall through */
2404 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2410 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2412 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2413 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2414 IV flags = PerlIOBase(f)->flags;
2424 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2431 /* Test code - delete when it works ... */
2438 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2446 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2447 ptr, chk, flags, c->nl, b->end, cnt);
2454 /* They have taken what we lied about */
2461 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2465 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2467 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2468 return PerlIOBuf_write(f,vbuf,count);
2471 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2472 const STDCHAR *buf = (const STDCHAR *) vbuf;
2473 const STDCHAR *ebuf = buf+count;
2476 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2480 STDCHAR *eptr = b->buf+b->bufsiz;
2481 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2482 while (buf < ebuf && b->ptr < eptr)
2486 if ((b->ptr + 2) > eptr)
2488 /* Not room for both */
2494 *(b->ptr)++ = 0xd; /* CR */
2495 *(b->ptr)++ = 0xa; /* LF */
2497 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2516 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2518 return (buf - (STDCHAR *) vbuf);
2523 PerlIOCrlf_flush(PerlIO *f)
2525 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2531 return PerlIOBuf_flush(f);
2534 PerlIO_funcs PerlIO_crlf = {
2537 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2543 PerlIOBase_noop_ok, /* popped */
2544 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2545 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2546 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2554 PerlIOBase_clearerr,
2555 PerlIOBuf_setlinebuf,
2560 PerlIOCrlf_set_ptrcnt,
2564 /*--------------------------------------------------------------------------------------*/
2565 /* mmap as "buffer" layer */
2569 PerlIOBuf base; /* PerlIOBuf stuff */
2570 Mmap_t mptr; /* Mapped address */
2571 Size_t len; /* mapped length */
2572 STDCHAR *bbuf; /* malloced buffer if map fails */
2575 static size_t page_size = 0;
2578 PerlIOMmap_map(PerlIO *f)
2581 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2582 PerlIOBuf *b = &m->base;
2583 IV flags = PerlIOBase(f)->flags;
2587 if (flags & PERLIO_F_CANREAD)
2589 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2590 int fd = PerlIO_fileno(f);
2592 code = fstat(fd,&st);
2593 if (code == 0 && S_ISREG(st.st_mode))
2595 SSize_t len = st.st_size - b->posn;
2600 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2602 SETERRNO(0,SS$_NORMAL);
2603 # ifdef _SC_PAGESIZE
2604 page_size = sysconf(_SC_PAGESIZE);
2606 page_size = sysconf(_SC_PAGE_SIZE);
2608 if ((long)page_size < 0) {
2613 (void)SvUPGRADE(error, SVt_PV);
2614 msg = SvPVx(error, n_a);
2615 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2618 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2622 # ifdef HAS_GETPAGESIZE
2623 page_size = getpagesize();
2625 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2626 page_size = PAGESIZE; /* compiletime, bad */
2630 if ((IV)page_size <= 0)
2631 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2635 /* This is a hack - should never happen - open should have set it ! */
2636 b->posn = PerlIO_tell(PerlIONext(f));
2638 posn = (b->posn / page_size) * page_size;
2639 len = st.st_size - posn;
2640 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2641 if (m->mptr && m->mptr != (Mmap_t) -1)
2643 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2644 madvise(m->mptr, len, MADV_SEQUENTIAL);
2646 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2647 b->end = ((STDCHAR *)m->mptr) + len;
2648 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2659 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2661 b->ptr = b->end = b->ptr;
2670 PerlIOMmap_unmap(PerlIO *f)
2672 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2673 PerlIOBuf *b = &m->base;
2679 code = munmap(m->mptr, m->len);
2683 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2686 b->ptr = b->end = b->buf;
2687 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2693 PerlIOMmap_get_base(PerlIO *f)
2695 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2696 PerlIOBuf *b = &m->base;
2697 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2699 /* Already have a readbuffer in progress */
2704 /* We have a write buffer or flushed PerlIOBuf read buffer */
2705 m->bbuf = b->buf; /* save it in case we need it again */
2706 b->buf = NULL; /* Clear to trigger below */
2710 PerlIOMmap_map(f); /* Try and map it */
2713 /* Map did not work - recover PerlIOBuf buffer if we have one */
2717 b->ptr = b->end = b->buf;
2720 return PerlIOBuf_get_base(f);
2724 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2726 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2727 PerlIOBuf *b = &m->base;
2728 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2730 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2733 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2738 /* Loose the unwritable mapped buffer */
2740 /* If flush took the "buffer" see if we have one from before */
2741 if (!b->buf && m->bbuf)
2745 PerlIOBuf_get_base(f);
2749 return PerlIOBuf_unread(f,vbuf,count);
2753 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2755 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2756 PerlIOBuf *b = &m->base;
2757 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2759 /* No, or wrong sort of, buffer */
2762 if (PerlIOMmap_unmap(f) != 0)
2765 /* If unmap took the "buffer" see if we have one from before */
2766 if (!b->buf && m->bbuf)
2770 PerlIOBuf_get_base(f);
2774 return PerlIOBuf_write(f,vbuf,count);
2778 PerlIOMmap_flush(PerlIO *f)
2780 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2781 PerlIOBuf *b = &m->base;
2782 IV code = PerlIOBuf_flush(f);
2783 /* Now we are "synced" at PerlIOBuf level */
2788 /* Unmap the buffer */
2789 if (PerlIOMmap_unmap(f) != 0)
2794 /* We seem to have a PerlIOBuf buffer which was not mapped
2795 * remember it in case we need one later
2804 PerlIOMmap_fill(PerlIO *f)
2806 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2807 IV code = PerlIO_flush(f);
2808 if (code == 0 && !b->buf)
2810 code = PerlIOMmap_map(f);
2812 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2814 code = PerlIOBuf_fill(f);
2820 PerlIOMmap_close(PerlIO *f)
2822 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2823 PerlIOBuf *b = &m->base;
2824 IV code = PerlIO_flush(f);
2829 b->ptr = b->end = b->buf;
2831 if (PerlIOBuf_close(f) != 0)
2837 PerlIO_funcs PerlIO_mmap = {
2857 PerlIOBase_clearerr,
2858 PerlIOBuf_setlinebuf,
2859 PerlIOMmap_get_base,
2863 PerlIOBuf_set_ptrcnt,
2866 #endif /* HAS_MMAP */
2873 atexit(&PerlIO_cleanup);
2882 PerlIO_stdstreams();
2886 #undef PerlIO_stdout
2891 PerlIO_stdstreams();
2895 #undef PerlIO_stderr
2900 PerlIO_stdstreams();
2904 /*--------------------------------------------------------------------------------------*/
2906 #undef PerlIO_getname
2908 PerlIO_getname(PerlIO *f, char *buf)
2911 Perl_croak(aTHX_ "Don't know how to get file name");
2916 /*--------------------------------------------------------------------------------------*/
2917 /* Functions which can be called on any kind of PerlIO implemented
2923 PerlIO_getc(PerlIO *f)
2926 SSize_t count = PerlIO_read(f,buf,1);
2929 return (unsigned char) buf[0];
2934 #undef PerlIO_ungetc
2936 PerlIO_ungetc(PerlIO *f, int ch)
2941 if (PerlIO_unread(f,&buf,1) == 1)
2949 PerlIO_putc(PerlIO *f, int ch)
2952 return PerlIO_write(f,&buf,1);
2957 PerlIO_puts(PerlIO *f, const char *s)
2959 STRLEN len = strlen(s);
2960 return PerlIO_write(f,s,len);
2963 #undef PerlIO_rewind
2965 PerlIO_rewind(PerlIO *f)
2967 PerlIO_seek(f,(Off_t)0,SEEK_SET);
2971 #undef PerlIO_vprintf
2973 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2976 SV *sv = newSVpvn("",0);
2981 Perl_va_copy(ap, apc);
2982 sv_vcatpvf(sv, fmt, &apc);
2984 sv_vcatpvf(sv, fmt, &ap);
2987 return PerlIO_write(f,s,len);
2990 #undef PerlIO_printf
2992 PerlIO_printf(PerlIO *f,const char *fmt,...)
2997 result = PerlIO_vprintf(f,fmt,ap);
3002 #undef PerlIO_stdoutf
3004 PerlIO_stdoutf(const char *fmt,...)
3009 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3014 #undef PerlIO_tmpfile
3016 PerlIO_tmpfile(void)
3018 /* I have no idea how portable mkstemp() is ... */
3019 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3021 FILE *stdio = PerlSIO_tmpfile();
3024 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
3030 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3031 int fd = mkstemp(SvPVX(sv));
3035 f = PerlIO_fdopen(fd,"w+");
3038 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3040 PerlLIO_unlink(SvPVX(sv));
3050 #endif /* USE_SFIO */
3051 #endif /* PERLIO_IS_STDIO */
3053 /*======================================================================================*/
3054 /* Now some functions in terms of above which may be needed even if
3055 we are not in true PerlIO mode
3059 #undef PerlIO_setpos
3061 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3063 return PerlIO_seek(f,*pos,0);
3066 #ifndef PERLIO_IS_STDIO
3067 #undef PerlIO_setpos
3069 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3071 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3072 return fsetpos64(f, pos);
3074 return fsetpos(f, pos);
3081 #undef PerlIO_getpos
3083 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3085 *pos = PerlIO_tell(f);
3086 return *pos == -1 ? -1 : 0;
3089 #ifndef PERLIO_IS_STDIO
3090 #undef PerlIO_getpos
3092 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3094 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3095 return fgetpos64(f, pos);
3097 return fgetpos(f, pos);
3103 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3106 vprintf(char *pat, char *args)
3108 _doprnt(pat, args, stdout);
3109 return 0; /* wrong, but perl doesn't use the return value */
3113 vfprintf(FILE *fd, char *pat, char *args)
3115 _doprnt(pat, args, fd);
3116 return 0; /* wrong, but perl doesn't use the return value */
3121 #ifndef PerlIO_vsprintf
3123 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3125 int val = vsprintf(s, fmt, ap);
3128 if (strlen(s) >= (STRLEN)n)
3131 (void)PerlIO_puts(Perl_error_log,
3132 "panic: sprintf overflow - memory corrupted!\n");
3140 #ifndef PerlIO_sprintf
3142 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3147 result = PerlIO_vsprintf(s, n, fmt, ap);
3153 #endif /* !PERL_IMPLICIT_SYS */