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(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)
1167 int oflags = PerlIOUnix_oflags(mode);
1170 int fd = PerlLIO_open3(path,oflags,0666);
1173 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1176 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1183 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1185 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1186 int oflags = PerlIOUnix_oflags(mode);
1187 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1188 (*PerlIOBase(f)->tab->Close)(f);
1192 int fd = PerlLIO_open3(path,oflags,0666);
1197 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1205 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1208 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1209 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1213 SSize_t len = PerlLIO_read(fd,vbuf,count);
1214 if (len >= 0 || errno != EINTR)
1217 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1218 else if (len == 0 && count != 0)
1219 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1226 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1229 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1232 SSize_t len = PerlLIO_write(fd,vbuf,count);
1233 if (len >= 0 || errno != EINTR)
1236 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1243 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1246 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1247 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1248 return (new == (Off_t) -1) ? -1 : 0;
1252 PerlIOUnix_tell(PerlIO *f)
1255 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1259 PerlIOUnix_close(PerlIO *f)
1262 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1264 while (PerlLIO_close(fd) != 0)
1274 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1279 PerlIO_funcs PerlIO_unix = {
1295 PerlIOBase_noop_ok, /* flush */
1296 PerlIOBase_noop_fail, /* fill */
1299 PerlIOBase_clearerr,
1300 PerlIOBase_setlinebuf,
1301 NULL, /* get_base */
1302 NULL, /* get_bufsiz */
1305 NULL, /* set_ptrcnt */
1308 /*--------------------------------------------------------------------------------------*/
1309 /* stdio as a layer */
1313 struct _PerlIO base;
1314 FILE * stdio; /* The stream */
1318 PerlIOStdio_fileno(PerlIO *f)
1321 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1325 PerlIOStdio_mode(const char *mode,char *tmode)
1327 const char *ret = mode;
1328 if (O_BINARY != O_TEXT)
1330 ret = (const char *) tmode;
1342 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1361 stdio = PerlSIO_stdin;
1364 stdio = PerlSIO_stdout;
1367 stdio = PerlSIO_stderr;
1373 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1377 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1384 #undef PerlIO_importFILE
1386 PerlIO_importFILE(FILE *stdio, int fl)
1391 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1398 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1402 FILE *stdio = PerlSIO_fopen(path,mode);
1406 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
1407 (mode = PerlIOStdio_mode(mode,tmode))),
1415 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1418 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1420 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1428 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1431 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1435 STDCHAR *buf = (STDCHAR *) vbuf;
1436 /* Perl is expecting PerlIO_getc() to fill the buffer
1437 * Linux's stdio does not do that for fread()
1439 int ch = PerlSIO_fgetc(s);
1447 got = PerlSIO_fread(vbuf,1,count,s);
1452 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1455 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1456 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1460 int ch = *buf-- & 0xff;
1461 if (PerlSIO_ungetc(ch,s) != ch)
1470 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1473 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1477 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1480 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1481 return PerlSIO_fseek(stdio,offset,whence);
1485 PerlIOStdio_tell(PerlIO *f)
1488 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1489 return PerlSIO_ftell(stdio);
1493 PerlIOStdio_close(PerlIO *f)
1496 int optval, optlen = sizeof(int);
1497 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1499 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1500 PerlSIO_fclose(stdio) :
1501 close(PerlIO_fileno(f)));
1505 PerlIOStdio_flush(PerlIO *f)
1508 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1509 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1511 return PerlSIO_fflush(stdio);
1516 /* FIXME: This discards ungetc() and pre-read stuff which is
1517 not right if this is just a "sync" from a layer above
1518 Suspect right design is to do _this_ but not have layer above
1519 flush this layer read-to-read
1521 /* Not writeable - sync by attempting a seek */
1523 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1531 PerlIOStdio_fill(PerlIO *f)
1534 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1536 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1537 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1539 if (PerlSIO_fflush(stdio) != 0)
1542 c = PerlSIO_fgetc(stdio);
1543 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1549 PerlIOStdio_eof(PerlIO *f)
1552 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1556 PerlIOStdio_error(PerlIO *f)
1559 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1563 PerlIOStdio_clearerr(PerlIO *f)
1566 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1570 PerlIOStdio_setlinebuf(PerlIO *f)
1573 #ifdef HAS_SETLINEBUF
1574 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1576 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1582 PerlIOStdio_get_base(PerlIO *f)
1585 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1586 return PerlSIO_get_base(stdio);
1590 PerlIOStdio_get_bufsiz(PerlIO *f)
1593 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1594 return PerlSIO_get_bufsiz(stdio);
1598 #ifdef USE_STDIO_PTR
1600 PerlIOStdio_get_ptr(PerlIO *f)
1603 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1604 return PerlSIO_get_ptr(stdio);
1608 PerlIOStdio_get_cnt(PerlIO *f)
1611 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1612 return PerlSIO_get_cnt(stdio);
1616 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1619 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1622 #ifdef STDIO_PTR_LVALUE
1623 PerlSIO_set_ptr(stdio,ptr);
1624 #ifdef STDIO_PTR_LVAL_SETS_CNT
1625 if (PerlSIO_get_cnt(stdio) != (cnt))
1628 assert(PerlSIO_get_cnt(stdio) == (cnt));
1631 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1632 /* Setting ptr _does_ change cnt - we are done */
1635 #else /* STDIO_PTR_LVALUE */
1637 #endif /* STDIO_PTR_LVALUE */
1639 /* Now (or only) set cnt */
1640 #ifdef STDIO_CNT_LVALUE
1641 PerlSIO_set_cnt(stdio,cnt);
1642 #else /* STDIO_CNT_LVALUE */
1643 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1644 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1645 #else /* STDIO_PTR_LVAL_SETS_CNT */
1647 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1648 #endif /* STDIO_CNT_LVALUE */
1653 PerlIO_funcs PerlIO_stdio = {
1655 sizeof(PerlIOStdio),
1673 PerlIOStdio_clearerr,
1674 PerlIOStdio_setlinebuf,
1676 PerlIOStdio_get_base,
1677 PerlIOStdio_get_bufsiz,
1682 #ifdef USE_STDIO_PTR
1683 PerlIOStdio_get_ptr,
1684 PerlIOStdio_get_cnt,
1685 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1686 PerlIOStdio_set_ptrcnt
1687 #else /* STDIO_PTR_LVALUE */
1689 #endif /* STDIO_PTR_LVALUE */
1690 #else /* USE_STDIO_PTR */
1694 #endif /* USE_STDIO_PTR */
1697 #undef PerlIO_exportFILE
1699 PerlIO_exportFILE(PerlIO *f, int fl)
1702 /* Should really push stdio discipline when we have them */
1703 return fdopen(PerlIO_fileno(f),"r+");
1706 #undef PerlIO_findFILE
1708 PerlIO_findFILE(PerlIO *f)
1710 return PerlIO_exportFILE(f,0);
1713 #undef PerlIO_releaseFILE
1715 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1719 /*--------------------------------------------------------------------------------------*/
1720 /* perlio buffer layer */
1723 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1725 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1726 b->posn = PerlIO_tell(PerlIONext(f));
1727 return PerlIOBase_pushed(f,mode);
1731 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1734 PerlIO_funcs *tab = PerlIO_default_btm();
1742 #if O_BINARY != O_TEXT
1743 /* do something about failing setmode()? --jhi */
1744 PerlLIO_setmode(fd, O_BINARY);
1746 f = (*tab->Fdopen)(tab,fd,mode);
1749 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1750 if (init && fd == 2)
1752 /* Initial stderr is unbuffered */
1753 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1756 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1757 self->name,f,fd,mode,PerlIOBase(f)->flags);
1764 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1766 PerlIO_funcs *tab = PerlIO_default_btm();
1767 PerlIO *f = (*tab->Open)(tab,path,mode);
1770 PerlIO_push(f,self,mode);
1776 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1778 PerlIO *next = PerlIONext(f);
1779 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1781 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1785 /* This "flush" is akin to sfio's sync in that it handles files in either
1789 PerlIOBuf_flush(PerlIO *f)
1791 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1793 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1795 /* write() the buffer */
1796 STDCHAR *p = b->buf;
1798 PerlIO *n = PerlIONext(f);
1801 count = PerlIO_write(n,p,b->ptr - p);
1806 else if (count < 0 || PerlIO_error(n))
1808 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1813 b->posn += (p - b->buf);
1815 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1817 /* Note position change */
1818 b->posn += (b->ptr - b->buf);
1819 if (b->ptr < b->end)
1821 /* We did not consume all of it */
1822 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1824 b->posn = PerlIO_tell(PerlIONext(f));
1828 b->ptr = b->end = b->buf;
1829 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1830 /* FIXME: Is this right for read case ? */
1831 if (PerlIO_flush(PerlIONext(f)) != 0)
1837 PerlIOBuf_fill(PerlIO *f)
1839 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1840 PerlIO *n = PerlIONext(f);
1842 /* FIXME: doing the down-stream flush is a bad idea if it causes
1843 pre-read data in stdio buffer to be discarded
1844 but this is too simplistic - as it skips _our_ hosekeeping
1845 and breaks tell tests.
1846 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1850 if (PerlIO_flush(f) != 0)
1853 b->ptr = b->end = b->buf;
1854 if (PerlIO_fast_gets(n))
1856 /* Layer below is also buffered
1857 * We do _NOT_ want to call its ->Read() because that will loop
1858 * till it gets what we asked for which may hang on a pipe etc.
1859 * Instead take anything it has to hand, or ask it to fill _once_.
1861 avail = PerlIO_get_cnt(n);
1864 avail = PerlIO_fill(n);
1866 avail = PerlIO_get_cnt(n);
1869 if (!PerlIO_error(n) && PerlIO_eof(n))
1875 STDCHAR *ptr = PerlIO_get_ptr(n);
1876 SSize_t cnt = avail;
1877 if (avail > b->bufsiz)
1879 Copy(ptr,b->buf,avail,STDCHAR);
1880 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1885 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1890 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1892 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1895 b->end = b->buf+avail;
1896 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1901 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1903 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1904 STDCHAR *buf = (STDCHAR *) vbuf;
1909 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1913 SSize_t avail = PerlIO_get_cnt(f);
1914 SSize_t take = (count < avail) ? count : avail;
1917 STDCHAR *ptr = PerlIO_get_ptr(f);
1918 Copy(ptr,buf,take,STDCHAR);
1919 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1923 if (count > 0 && avail <= 0)
1925 if (PerlIO_fill(f) != 0)
1929 return (buf - (STDCHAR *) vbuf);
1935 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1937 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1938 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1941 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1947 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1949 avail = (b->ptr - b->buf);
1954 b->end = b->buf + avail;
1956 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1957 b->posn -= b->bufsiz;
1959 if (avail > (SSize_t) count)
1967 Copy(buf,b->ptr,avail,STDCHAR);
1971 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1978 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1980 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1981 const STDCHAR *buf = (const STDCHAR *) vbuf;
1985 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1989 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1990 if ((SSize_t) count < avail)
1992 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1993 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2013 Copy(buf,b->ptr,avail,STDCHAR);
2020 if (b->ptr >= (b->buf + b->bufsiz))
2023 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2029 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2032 if ((code = PerlIO_flush(f)) == 0)
2034 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2035 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2036 code = PerlIO_seek(PerlIONext(f),offset,whence);
2039 b->posn = PerlIO_tell(PerlIONext(f));
2046 PerlIOBuf_tell(PerlIO *f)
2048 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2049 Off_t posn = b->posn;
2051 posn += (b->ptr - b->buf);
2056 PerlIOBuf_close(PerlIO *f)
2058 IV code = PerlIOBase_close(f);
2059 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2060 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2065 b->ptr = b->end = b->buf;
2066 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2071 PerlIOBuf_setlinebuf(PerlIO *f)
2075 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2080 PerlIOBuf_get_ptr(PerlIO *f)
2082 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2089 PerlIOBuf_get_cnt(PerlIO *f)
2091 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2094 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2095 return (b->end - b->ptr);
2100 PerlIOBuf_get_base(PerlIO *f)
2102 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2107 New('B',b->buf,b->bufsiz,STDCHAR);
2110 b->buf = (STDCHAR *)&b->oneword;
2111 b->bufsiz = sizeof(b->oneword);
2120 PerlIOBuf_bufsiz(PerlIO *f)
2122 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2125 return (b->end - b->buf);
2129 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2131 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2135 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2138 assert(PerlIO_get_cnt(f) == cnt);
2139 assert(b->ptr >= b->buf);
2141 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2144 PerlIO_funcs PerlIO_perlio = {
2164 PerlIOBase_clearerr,
2165 PerlIOBuf_setlinebuf,
2170 PerlIOBuf_set_ptrcnt,
2173 /*--------------------------------------------------------------------------------------*/
2174 /* Temp layer to hold unread chars when cannot do it any other way */
2177 PerlIOPending_fill(PerlIO *f)
2179 /* Should never happen */
2185 PerlIOPending_close(PerlIO *f)
2187 /* A tad tricky - flush pops us, then we close new top */
2189 return PerlIO_close(f);
2193 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2195 /* A tad tricky - flush pops us, then we seek new top */
2197 return PerlIO_seek(f,offset,whence);
2202 PerlIOPending_flush(PerlIO *f)
2204 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2205 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2215 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2223 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2228 PerlIOPending_pushed(PerlIO *f,const char *mode)
2230 IV code = PerlIOBuf_pushed(f,mode);
2231 PerlIOl *l = PerlIOBase(f);
2232 /* Our PerlIO_fast_gets must match what we are pushed on,
2233 or sv_gets() etc. get muddled when it changes mid-string
2236 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2237 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2242 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2244 SSize_t avail = PerlIO_get_cnt(f);
2249 got = PerlIOBuf_read(f,vbuf,avail);
2251 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2256 PerlIO_funcs PerlIO_pending = {
2264 PerlIOPending_pushed,
2271 PerlIOPending_close,
2272 PerlIOPending_flush,
2276 PerlIOBase_clearerr,
2277 PerlIOBuf_setlinebuf,
2282 PerlIOPending_set_ptrcnt,
2287 /*--------------------------------------------------------------------------------------*/
2288 /* crlf - translation
2289 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2290 to hand back a line at a time and keeping a record of which nl we "lied" about.
2291 On write translate "\n" to CR,LF
2296 PerlIOBuf base; /* PerlIOBuf stuff */
2297 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2301 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2304 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2305 code = PerlIOBuf_pushed(f,mode);
2307 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2308 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2309 PerlIOBase(f)->flags);
2316 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2318 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2324 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2325 return PerlIOBuf_unread(f,vbuf,count);
2328 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2329 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2331 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2337 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2339 b->end = b->ptr = b->buf + b->bufsiz;
2340 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2341 b->posn -= b->bufsiz;
2343 while (count > 0 && b->ptr > b->buf)
2348 if (b->ptr - 2 >= b->buf)
2374 PerlIOCrlf_get_cnt(PerlIO *f)
2376 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2379 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2381 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2382 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2384 STDCHAR *nl = b->ptr;
2386 while (nl < b->end && *nl != 0xd)
2388 if (nl < b->end && *nl == 0xd)
2400 /* Not CR,LF but just CR */
2407 /* Blast - found CR as last char in buffer */
2410 /* They may not care, defer work as long as possible */
2411 return (nl - b->ptr);
2417 b->ptr++; /* say we have read it as far as flush() is concerned */
2418 b->buf++; /* Leave space an front of buffer */
2419 b->bufsiz--; /* Buffer is thus smaller */
2420 code = PerlIO_fill(f); /* Fetch some more */
2421 b->bufsiz++; /* Restore size for next time */
2422 b->buf--; /* Point at space */
2423 b->ptr = nl = b->buf; /* Which is what we hand off */
2424 b->posn--; /* Buffer starts here */
2425 *nl = 0xd; /* Fill in the CR */
2427 goto test; /* fill() call worked */
2428 /* CR at EOF - just fall through */
2433 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2439 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2441 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2442 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2443 IV flags = PerlIOBase(f)->flags;
2453 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2460 /* Test code - delete when it works ... */
2467 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2475 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2476 ptr, chk, flags, c->nl, b->end, cnt);
2483 /* They have taken what we lied about */
2490 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2494 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2496 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2497 return PerlIOBuf_write(f,vbuf,count);
2500 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2501 const STDCHAR *buf = (const STDCHAR *) vbuf;
2502 const STDCHAR *ebuf = buf+count;
2505 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2509 STDCHAR *eptr = b->buf+b->bufsiz;
2510 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2511 while (buf < ebuf && b->ptr < eptr)
2515 if ((b->ptr + 2) > eptr)
2517 /* Not room for both */
2523 *(b->ptr)++ = 0xd; /* CR */
2524 *(b->ptr)++ = 0xa; /* LF */
2526 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2545 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2547 return (buf - (STDCHAR *) vbuf);
2552 PerlIOCrlf_flush(PerlIO *f)
2554 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2560 return PerlIOBuf_flush(f);
2563 PerlIO_funcs PerlIO_crlf = {
2566 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2572 PerlIOBase_noop_ok, /* popped */
2573 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2574 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2575 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2583 PerlIOBase_clearerr,
2584 PerlIOBuf_setlinebuf,
2589 PerlIOCrlf_set_ptrcnt,
2593 /*--------------------------------------------------------------------------------------*/
2594 /* mmap as "buffer" layer */
2598 PerlIOBuf base; /* PerlIOBuf stuff */
2599 Mmap_t mptr; /* Mapped address */
2600 Size_t len; /* mapped length */
2601 STDCHAR *bbuf; /* malloced buffer if map fails */
2604 static size_t page_size = 0;
2607 PerlIOMmap_map(PerlIO *f)
2610 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2611 PerlIOBuf *b = &m->base;
2612 IV flags = PerlIOBase(f)->flags;
2616 if (flags & PERLIO_F_CANREAD)
2618 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2619 int fd = PerlIO_fileno(f);
2621 code = fstat(fd,&st);
2622 if (code == 0 && S_ISREG(st.st_mode))
2624 SSize_t len = st.st_size - b->posn;
2629 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2631 SETERRNO(0,SS$_NORMAL);
2632 # ifdef _SC_PAGESIZE
2633 page_size = sysconf(_SC_PAGESIZE);
2635 page_size = sysconf(_SC_PAGE_SIZE);
2637 if ((long)page_size < 0) {
2642 (void)SvUPGRADE(error, SVt_PV);
2643 msg = SvPVx(error, n_a);
2644 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2647 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2651 # ifdef HAS_GETPAGESIZE
2652 page_size = getpagesize();
2654 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2655 page_size = PAGESIZE; /* compiletime, bad */
2659 if ((IV)page_size <= 0)
2660 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2664 /* This is a hack - should never happen - open should have set it ! */
2665 b->posn = PerlIO_tell(PerlIONext(f));
2667 posn = (b->posn / page_size) * page_size;
2668 len = st.st_size - posn;
2669 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2670 if (m->mptr && m->mptr != (Mmap_t) -1)
2672 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2673 madvise(m->mptr, len, MADV_SEQUENTIAL);
2675 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2676 b->end = ((STDCHAR *)m->mptr) + len;
2677 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2688 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2690 b->ptr = b->end = b->ptr;
2699 PerlIOMmap_unmap(PerlIO *f)
2701 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2702 PerlIOBuf *b = &m->base;
2708 code = munmap(m->mptr, m->len);
2712 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2715 b->ptr = b->end = b->buf;
2716 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2722 PerlIOMmap_get_base(PerlIO *f)
2724 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2725 PerlIOBuf *b = &m->base;
2726 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2728 /* Already have a readbuffer in progress */
2733 /* We have a write buffer or flushed PerlIOBuf read buffer */
2734 m->bbuf = b->buf; /* save it in case we need it again */
2735 b->buf = NULL; /* Clear to trigger below */
2739 PerlIOMmap_map(f); /* Try and map it */
2742 /* Map did not work - recover PerlIOBuf buffer if we have one */
2746 b->ptr = b->end = b->buf;
2749 return PerlIOBuf_get_base(f);
2753 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2755 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2756 PerlIOBuf *b = &m->base;
2757 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2759 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2762 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2767 /* Loose the unwritable mapped buffer */
2769 /* If flush took the "buffer" see if we have one from before */
2770 if (!b->buf && m->bbuf)
2774 PerlIOBuf_get_base(f);
2778 return PerlIOBuf_unread(f,vbuf,count);
2782 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2784 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2785 PerlIOBuf *b = &m->base;
2786 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2788 /* No, or wrong sort of, buffer */
2791 if (PerlIOMmap_unmap(f) != 0)
2794 /* If unmap took the "buffer" see if we have one from before */
2795 if (!b->buf && m->bbuf)
2799 PerlIOBuf_get_base(f);
2803 return PerlIOBuf_write(f,vbuf,count);
2807 PerlIOMmap_flush(PerlIO *f)
2809 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2810 PerlIOBuf *b = &m->base;
2811 IV code = PerlIOBuf_flush(f);
2812 /* Now we are "synced" at PerlIOBuf level */
2817 /* Unmap the buffer */
2818 if (PerlIOMmap_unmap(f) != 0)
2823 /* We seem to have a PerlIOBuf buffer which was not mapped
2824 * remember it in case we need one later
2833 PerlIOMmap_fill(PerlIO *f)
2835 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2836 IV code = PerlIO_flush(f);
2837 if (code == 0 && !b->buf)
2839 code = PerlIOMmap_map(f);
2841 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2843 code = PerlIOBuf_fill(f);
2849 PerlIOMmap_close(PerlIO *f)
2851 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2852 PerlIOBuf *b = &m->base;
2853 IV code = PerlIO_flush(f);
2858 b->ptr = b->end = b->buf;
2860 if (PerlIOBuf_close(f) != 0)
2866 PerlIO_funcs PerlIO_mmap = {
2886 PerlIOBase_clearerr,
2887 PerlIOBuf_setlinebuf,
2888 PerlIOMmap_get_base,
2892 PerlIOBuf_set_ptrcnt,
2895 #endif /* HAS_MMAP */
2902 atexit(&PerlIO_cleanup);
2911 PerlIO_stdstreams();
2915 #undef PerlIO_stdout
2920 PerlIO_stdstreams();
2924 #undef PerlIO_stderr
2929 PerlIO_stdstreams();
2933 /*--------------------------------------------------------------------------------------*/
2935 #undef PerlIO_getname
2937 PerlIO_getname(PerlIO *f, char *buf)
2940 Perl_croak(aTHX_ "Don't know how to get file name");
2945 /*--------------------------------------------------------------------------------------*/
2946 /* Functions which can be called on any kind of PerlIO implemented
2952 PerlIO_getc(PerlIO *f)
2955 SSize_t count = PerlIO_read(f,buf,1);
2958 return (unsigned char) buf[0];
2963 #undef PerlIO_ungetc
2965 PerlIO_ungetc(PerlIO *f, int ch)
2970 if (PerlIO_unread(f,&buf,1) == 1)
2978 PerlIO_putc(PerlIO *f, int ch)
2981 return PerlIO_write(f,&buf,1);
2986 PerlIO_puts(PerlIO *f, const char *s)
2988 STRLEN len = strlen(s);
2989 return PerlIO_write(f,s,len);
2992 #undef PerlIO_rewind
2994 PerlIO_rewind(PerlIO *f)
2996 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3000 #undef PerlIO_vprintf
3002 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3005 SV *sv = newSVpvn("",0);
3010 Perl_va_copy(ap, apc);
3011 sv_vcatpvf(sv, fmt, &apc);
3013 sv_vcatpvf(sv, fmt, &ap);
3016 return PerlIO_write(f,s,len);
3019 #undef PerlIO_printf
3021 PerlIO_printf(PerlIO *f,const char *fmt,...)
3026 result = PerlIO_vprintf(f,fmt,ap);
3031 #undef PerlIO_stdoutf
3033 PerlIO_stdoutf(const char *fmt,...)
3038 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3043 #undef PerlIO_tmpfile
3045 PerlIO_tmpfile(void)
3047 /* I have no idea how portable mkstemp() is ... */
3048 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3051 FILE *stdio = PerlSIO_tmpfile();
3054 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
3060 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3061 int fd = mkstemp(SvPVX(sv));
3065 f = PerlIO_fdopen(fd,"w+");
3068 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3070 PerlLIO_unlink(SvPVX(sv));
3080 #endif /* USE_SFIO */
3081 #endif /* PERLIO_IS_STDIO */
3083 /*======================================================================================*/
3084 /* Now some functions in terms of above which may be needed even if
3085 we are not in true PerlIO mode
3089 #undef PerlIO_setpos
3091 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3093 return PerlIO_seek(f,*pos,0);
3096 #ifndef PERLIO_IS_STDIO
3097 #undef PerlIO_setpos
3099 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3101 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3102 return fsetpos64(f, pos);
3104 return fsetpos(f, pos);
3111 #undef PerlIO_getpos
3113 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3115 *pos = PerlIO_tell(f);
3116 return *pos == -1 ? -1 : 0;
3119 #ifndef PERLIO_IS_STDIO
3120 #undef PerlIO_getpos
3122 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3124 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3125 return fgetpos64(f, pos);
3127 return fgetpos(f, pos);
3133 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3136 vprintf(char *pat, char *args)
3138 _doprnt(pat, args, stdout);
3139 return 0; /* wrong, but perl doesn't use the return value */
3143 vfprintf(FILE *fd, char *pat, char *args)
3145 _doprnt(pat, args, fd);
3146 return 0; /* wrong, but perl doesn't use the return value */
3151 #ifndef PerlIO_vsprintf
3153 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3155 int val = vsprintf(s, fmt, ap);
3158 if (strlen(s) >= (STRLEN)n)
3161 (void)PerlIO_puts(Perl_error_log,
3162 "panic: sprintf overflow - memory corrupted!\n");
3170 #ifndef PerlIO_sprintf
3172 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3177 result = PerlIO_vsprintf(s, n, fmt, ap);