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)
1497 int optval, optlen = sizeof(int);
1499 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1502 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1503 PerlSIO_fclose(stdio) :
1504 close(PerlIO_fileno(f))
1506 PerlSIO_fclose(stdio)
1513 PerlIOStdio_flush(PerlIO *f)
1516 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1517 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1519 return PerlSIO_fflush(stdio);
1524 /* FIXME: This discards ungetc() and pre-read stuff which is
1525 not right if this is just a "sync" from a layer above
1526 Suspect right design is to do _this_ but not have layer above
1527 flush this layer read-to-read
1529 /* Not writeable - sync by attempting a seek */
1531 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1539 PerlIOStdio_fill(PerlIO *f)
1542 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1544 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1545 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1547 if (PerlSIO_fflush(stdio) != 0)
1550 c = PerlSIO_fgetc(stdio);
1551 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1557 PerlIOStdio_eof(PerlIO *f)
1560 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1564 PerlIOStdio_error(PerlIO *f)
1567 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1571 PerlIOStdio_clearerr(PerlIO *f)
1574 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1578 PerlIOStdio_setlinebuf(PerlIO *f)
1581 #ifdef HAS_SETLINEBUF
1582 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1584 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1590 PerlIOStdio_get_base(PerlIO *f)
1593 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1594 return PerlSIO_get_base(stdio);
1598 PerlIOStdio_get_bufsiz(PerlIO *f)
1601 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1602 return PerlSIO_get_bufsiz(stdio);
1606 #ifdef USE_STDIO_PTR
1608 PerlIOStdio_get_ptr(PerlIO *f)
1611 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1612 return PerlSIO_get_ptr(stdio);
1616 PerlIOStdio_get_cnt(PerlIO *f)
1619 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1620 return PerlSIO_get_cnt(stdio);
1624 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1627 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1630 #ifdef STDIO_PTR_LVALUE
1631 PerlSIO_set_ptr(stdio,ptr);
1632 #ifdef STDIO_PTR_LVAL_SETS_CNT
1633 if (PerlSIO_get_cnt(stdio) != (cnt))
1636 assert(PerlSIO_get_cnt(stdio) == (cnt));
1639 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1640 /* Setting ptr _does_ change cnt - we are done */
1643 #else /* STDIO_PTR_LVALUE */
1645 #endif /* STDIO_PTR_LVALUE */
1647 /* Now (or only) set cnt */
1648 #ifdef STDIO_CNT_LVALUE
1649 PerlSIO_set_cnt(stdio,cnt);
1650 #else /* STDIO_CNT_LVALUE */
1651 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1652 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1653 #else /* STDIO_PTR_LVAL_SETS_CNT */
1655 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1656 #endif /* STDIO_CNT_LVALUE */
1661 PerlIO_funcs PerlIO_stdio = {
1663 sizeof(PerlIOStdio),
1681 PerlIOStdio_clearerr,
1682 PerlIOStdio_setlinebuf,
1684 PerlIOStdio_get_base,
1685 PerlIOStdio_get_bufsiz,
1690 #ifdef USE_STDIO_PTR
1691 PerlIOStdio_get_ptr,
1692 PerlIOStdio_get_cnt,
1693 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1694 PerlIOStdio_set_ptrcnt
1695 #else /* STDIO_PTR_LVALUE */
1697 #endif /* STDIO_PTR_LVALUE */
1698 #else /* USE_STDIO_PTR */
1702 #endif /* USE_STDIO_PTR */
1705 #undef PerlIO_exportFILE
1707 PerlIO_exportFILE(PerlIO *f, int fl)
1710 /* Should really push stdio discipline when we have them */
1711 return fdopen(PerlIO_fileno(f),"r+");
1714 #undef PerlIO_findFILE
1716 PerlIO_findFILE(PerlIO *f)
1718 return PerlIO_exportFILE(f,0);
1721 #undef PerlIO_releaseFILE
1723 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1727 /*--------------------------------------------------------------------------------------*/
1728 /* perlio buffer layer */
1731 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1733 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1734 b->posn = PerlIO_tell(PerlIONext(f));
1735 return PerlIOBase_pushed(f,mode);
1739 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1742 PerlIO_funcs *tab = PerlIO_default_btm();
1750 #if O_BINARY != O_TEXT
1751 /* do something about failing setmode()? --jhi */
1752 PerlLIO_setmode(fd, O_BINARY);
1754 f = (*tab->Fdopen)(tab,fd,mode);
1757 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1758 if (init && fd == 2)
1760 /* Initial stderr is unbuffered */
1761 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1764 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1765 self->name,f,fd,mode,PerlIOBase(f)->flags);
1772 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1774 PerlIO_funcs *tab = PerlIO_default_btm();
1775 PerlIO *f = (*tab->Open)(tab,path,mode);
1778 PerlIO_push(f,self,mode);
1784 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1786 PerlIO *next = PerlIONext(f);
1787 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1789 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1793 /* This "flush" is akin to sfio's sync in that it handles files in either
1797 PerlIOBuf_flush(PerlIO *f)
1799 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1801 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1803 /* write() the buffer */
1804 STDCHAR *p = b->buf;
1806 PerlIO *n = PerlIONext(f);
1809 count = PerlIO_write(n,p,b->ptr - p);
1814 else if (count < 0 || PerlIO_error(n))
1816 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1821 b->posn += (p - b->buf);
1823 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1825 /* Note position change */
1826 b->posn += (b->ptr - b->buf);
1827 if (b->ptr < b->end)
1829 /* We did not consume all of it */
1830 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1832 b->posn = PerlIO_tell(PerlIONext(f));
1836 b->ptr = b->end = b->buf;
1837 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1838 /* FIXME: Is this right for read case ? */
1839 if (PerlIO_flush(PerlIONext(f)) != 0)
1845 PerlIOBuf_fill(PerlIO *f)
1847 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1848 PerlIO *n = PerlIONext(f);
1850 /* FIXME: doing the down-stream flush is a bad idea if it causes
1851 pre-read data in stdio buffer to be discarded
1852 but this is too simplistic - as it skips _our_ hosekeeping
1853 and breaks tell tests.
1854 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1858 if (PerlIO_flush(f) != 0)
1861 b->ptr = b->end = b->buf;
1862 if (PerlIO_fast_gets(n))
1864 /* Layer below is also buffered
1865 * We do _NOT_ want to call its ->Read() because that will loop
1866 * till it gets what we asked for which may hang on a pipe etc.
1867 * Instead take anything it has to hand, or ask it to fill _once_.
1869 avail = PerlIO_get_cnt(n);
1872 avail = PerlIO_fill(n);
1874 avail = PerlIO_get_cnt(n);
1877 if (!PerlIO_error(n) && PerlIO_eof(n))
1883 STDCHAR *ptr = PerlIO_get_ptr(n);
1884 SSize_t cnt = avail;
1885 if (avail > b->bufsiz)
1887 Copy(ptr,b->buf,avail,STDCHAR);
1888 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1893 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1898 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1900 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1903 b->end = b->buf+avail;
1904 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1909 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1911 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1912 STDCHAR *buf = (STDCHAR *) vbuf;
1917 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1921 SSize_t avail = PerlIO_get_cnt(f);
1922 SSize_t take = (count < avail) ? count : avail;
1925 STDCHAR *ptr = PerlIO_get_ptr(f);
1926 Copy(ptr,buf,take,STDCHAR);
1927 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1931 if (count > 0 && avail <= 0)
1933 if (PerlIO_fill(f) != 0)
1937 return (buf - (STDCHAR *) vbuf);
1943 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1945 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1946 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1949 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1955 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1957 avail = (b->ptr - b->buf);
1962 b->end = b->buf + avail;
1964 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1965 b->posn -= b->bufsiz;
1967 if (avail > (SSize_t) count)
1975 Copy(buf,b->ptr,avail,STDCHAR);
1979 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1986 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1988 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1989 const STDCHAR *buf = (const STDCHAR *) vbuf;
1993 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1997 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1998 if ((SSize_t) count < avail)
2000 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2001 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2021 Copy(buf,b->ptr,avail,STDCHAR);
2028 if (b->ptr >= (b->buf + b->bufsiz))
2031 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2037 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2040 if ((code = PerlIO_flush(f)) == 0)
2042 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2043 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2044 code = PerlIO_seek(PerlIONext(f),offset,whence);
2047 b->posn = PerlIO_tell(PerlIONext(f));
2054 PerlIOBuf_tell(PerlIO *f)
2056 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2057 Off_t posn = b->posn;
2059 posn += (b->ptr - b->buf);
2064 PerlIOBuf_close(PerlIO *f)
2066 IV code = PerlIOBase_close(f);
2067 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2068 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2073 b->ptr = b->end = b->buf;
2074 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2079 PerlIOBuf_setlinebuf(PerlIO *f)
2083 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2088 PerlIOBuf_get_ptr(PerlIO *f)
2090 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2097 PerlIOBuf_get_cnt(PerlIO *f)
2099 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2102 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2103 return (b->end - b->ptr);
2108 PerlIOBuf_get_base(PerlIO *f)
2110 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2115 New('B',b->buf,b->bufsiz,STDCHAR);
2118 b->buf = (STDCHAR *)&b->oneword;
2119 b->bufsiz = sizeof(b->oneword);
2128 PerlIOBuf_bufsiz(PerlIO *f)
2130 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2133 return (b->end - b->buf);
2137 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2139 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2143 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2146 assert(PerlIO_get_cnt(f) == cnt);
2147 assert(b->ptr >= b->buf);
2149 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2152 PerlIO_funcs PerlIO_perlio = {
2172 PerlIOBase_clearerr,
2173 PerlIOBuf_setlinebuf,
2178 PerlIOBuf_set_ptrcnt,
2181 /*--------------------------------------------------------------------------------------*/
2182 /* Temp layer to hold unread chars when cannot do it any other way */
2185 PerlIOPending_fill(PerlIO *f)
2187 /* Should never happen */
2193 PerlIOPending_close(PerlIO *f)
2195 /* A tad tricky - flush pops us, then we close new top */
2197 return PerlIO_close(f);
2201 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2203 /* A tad tricky - flush pops us, then we seek new top */
2205 return PerlIO_seek(f,offset,whence);
2210 PerlIOPending_flush(PerlIO *f)
2212 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2213 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2223 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2231 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2236 PerlIOPending_pushed(PerlIO *f,const char *mode)
2238 IV code = PerlIOBuf_pushed(f,mode);
2239 PerlIOl *l = PerlIOBase(f);
2240 /* Our PerlIO_fast_gets must match what we are pushed on,
2241 or sv_gets() etc. get muddled when it changes mid-string
2244 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2245 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2250 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2252 SSize_t avail = PerlIO_get_cnt(f);
2257 got = PerlIOBuf_read(f,vbuf,avail);
2259 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2264 PerlIO_funcs PerlIO_pending = {
2272 PerlIOPending_pushed,
2279 PerlIOPending_close,
2280 PerlIOPending_flush,
2284 PerlIOBase_clearerr,
2285 PerlIOBuf_setlinebuf,
2290 PerlIOPending_set_ptrcnt,
2295 /*--------------------------------------------------------------------------------------*/
2296 /* crlf - translation
2297 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2298 to hand back a line at a time and keeping a record of which nl we "lied" about.
2299 On write translate "\n" to CR,LF
2304 PerlIOBuf base; /* PerlIOBuf stuff */
2305 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2309 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2312 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2313 code = PerlIOBuf_pushed(f,mode);
2315 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2316 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2317 PerlIOBase(f)->flags);
2324 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2326 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2332 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2333 return PerlIOBuf_unread(f,vbuf,count);
2336 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2337 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2339 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2345 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2347 b->end = b->ptr = b->buf + b->bufsiz;
2348 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2349 b->posn -= b->bufsiz;
2351 while (count > 0 && b->ptr > b->buf)
2356 if (b->ptr - 2 >= b->buf)
2382 PerlIOCrlf_get_cnt(PerlIO *f)
2384 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2387 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2389 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2390 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2392 STDCHAR *nl = b->ptr;
2394 while (nl < b->end && *nl != 0xd)
2396 if (nl < b->end && *nl == 0xd)
2408 /* Not CR,LF but just CR */
2415 /* Blast - found CR as last char in buffer */
2418 /* They may not care, defer work as long as possible */
2419 return (nl - b->ptr);
2425 b->ptr++; /* say we have read it as far as flush() is concerned */
2426 b->buf++; /* Leave space an front of buffer */
2427 b->bufsiz--; /* Buffer is thus smaller */
2428 code = PerlIO_fill(f); /* Fetch some more */
2429 b->bufsiz++; /* Restore size for next time */
2430 b->buf--; /* Point at space */
2431 b->ptr = nl = b->buf; /* Which is what we hand off */
2432 b->posn--; /* Buffer starts here */
2433 *nl = 0xd; /* Fill in the CR */
2435 goto test; /* fill() call worked */
2436 /* CR at EOF - just fall through */
2441 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2447 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2449 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2450 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2451 IV flags = PerlIOBase(f)->flags;
2461 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2468 /* Test code - delete when it works ... */
2475 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2483 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2484 ptr, chk, flags, c->nl, b->end, cnt);
2491 /* They have taken what we lied about */
2498 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2502 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2504 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2505 return PerlIOBuf_write(f,vbuf,count);
2508 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2509 const STDCHAR *buf = (const STDCHAR *) vbuf;
2510 const STDCHAR *ebuf = buf+count;
2513 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2517 STDCHAR *eptr = b->buf+b->bufsiz;
2518 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2519 while (buf < ebuf && b->ptr < eptr)
2523 if ((b->ptr + 2) > eptr)
2525 /* Not room for both */
2531 *(b->ptr)++ = 0xd; /* CR */
2532 *(b->ptr)++ = 0xa; /* LF */
2534 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2553 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2555 return (buf - (STDCHAR *) vbuf);
2560 PerlIOCrlf_flush(PerlIO *f)
2562 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2568 return PerlIOBuf_flush(f);
2571 PerlIO_funcs PerlIO_crlf = {
2574 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2580 PerlIOBase_noop_ok, /* popped */
2581 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2582 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2583 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2591 PerlIOBase_clearerr,
2592 PerlIOBuf_setlinebuf,
2597 PerlIOCrlf_set_ptrcnt,
2601 /*--------------------------------------------------------------------------------------*/
2602 /* mmap as "buffer" layer */
2606 PerlIOBuf base; /* PerlIOBuf stuff */
2607 Mmap_t mptr; /* Mapped address */
2608 Size_t len; /* mapped length */
2609 STDCHAR *bbuf; /* malloced buffer if map fails */
2612 static size_t page_size = 0;
2615 PerlIOMmap_map(PerlIO *f)
2618 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2619 PerlIOBuf *b = &m->base;
2620 IV flags = PerlIOBase(f)->flags;
2624 if (flags & PERLIO_F_CANREAD)
2626 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2627 int fd = PerlIO_fileno(f);
2629 code = fstat(fd,&st);
2630 if (code == 0 && S_ISREG(st.st_mode))
2632 SSize_t len = st.st_size - b->posn;
2637 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2639 SETERRNO(0,SS$_NORMAL);
2640 # ifdef _SC_PAGESIZE
2641 page_size = sysconf(_SC_PAGESIZE);
2643 page_size = sysconf(_SC_PAGE_SIZE);
2645 if ((long)page_size < 0) {
2650 (void)SvUPGRADE(error, SVt_PV);
2651 msg = SvPVx(error, n_a);
2652 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2655 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2659 # ifdef HAS_GETPAGESIZE
2660 page_size = getpagesize();
2662 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2663 page_size = PAGESIZE; /* compiletime, bad */
2667 if ((IV)page_size <= 0)
2668 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2672 /* This is a hack - should never happen - open should have set it ! */
2673 b->posn = PerlIO_tell(PerlIONext(f));
2675 posn = (b->posn / page_size) * page_size;
2676 len = st.st_size - posn;
2677 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2678 if (m->mptr && m->mptr != (Mmap_t) -1)
2680 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2681 madvise(m->mptr, len, MADV_SEQUENTIAL);
2683 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2684 b->end = ((STDCHAR *)m->mptr) + len;
2685 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2696 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2698 b->ptr = b->end = b->ptr;
2707 PerlIOMmap_unmap(PerlIO *f)
2709 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2710 PerlIOBuf *b = &m->base;
2716 code = munmap(m->mptr, m->len);
2720 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2723 b->ptr = b->end = b->buf;
2724 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2730 PerlIOMmap_get_base(PerlIO *f)
2732 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2733 PerlIOBuf *b = &m->base;
2734 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2736 /* Already have a readbuffer in progress */
2741 /* We have a write buffer or flushed PerlIOBuf read buffer */
2742 m->bbuf = b->buf; /* save it in case we need it again */
2743 b->buf = NULL; /* Clear to trigger below */
2747 PerlIOMmap_map(f); /* Try and map it */
2750 /* Map did not work - recover PerlIOBuf buffer if we have one */
2754 b->ptr = b->end = b->buf;
2757 return PerlIOBuf_get_base(f);
2761 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2763 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2764 PerlIOBuf *b = &m->base;
2765 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2767 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2770 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2775 /* Loose the unwritable mapped buffer */
2777 /* If flush took the "buffer" see if we have one from before */
2778 if (!b->buf && m->bbuf)
2782 PerlIOBuf_get_base(f);
2786 return PerlIOBuf_unread(f,vbuf,count);
2790 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2792 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2793 PerlIOBuf *b = &m->base;
2794 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2796 /* No, or wrong sort of, buffer */
2799 if (PerlIOMmap_unmap(f) != 0)
2802 /* If unmap took the "buffer" see if we have one from before */
2803 if (!b->buf && m->bbuf)
2807 PerlIOBuf_get_base(f);
2811 return PerlIOBuf_write(f,vbuf,count);
2815 PerlIOMmap_flush(PerlIO *f)
2817 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2818 PerlIOBuf *b = &m->base;
2819 IV code = PerlIOBuf_flush(f);
2820 /* Now we are "synced" at PerlIOBuf level */
2825 /* Unmap the buffer */
2826 if (PerlIOMmap_unmap(f) != 0)
2831 /* We seem to have a PerlIOBuf buffer which was not mapped
2832 * remember it in case we need one later
2841 PerlIOMmap_fill(PerlIO *f)
2843 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2844 IV code = PerlIO_flush(f);
2845 if (code == 0 && !b->buf)
2847 code = PerlIOMmap_map(f);
2849 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2851 code = PerlIOBuf_fill(f);
2857 PerlIOMmap_close(PerlIO *f)
2859 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2860 PerlIOBuf *b = &m->base;
2861 IV code = PerlIO_flush(f);
2866 b->ptr = b->end = b->buf;
2868 if (PerlIOBuf_close(f) != 0)
2874 PerlIO_funcs PerlIO_mmap = {
2894 PerlIOBase_clearerr,
2895 PerlIOBuf_setlinebuf,
2896 PerlIOMmap_get_base,
2900 PerlIOBuf_set_ptrcnt,
2903 #endif /* HAS_MMAP */
2910 atexit(&PerlIO_cleanup);
2919 PerlIO_stdstreams();
2923 #undef PerlIO_stdout
2928 PerlIO_stdstreams();
2932 #undef PerlIO_stderr
2937 PerlIO_stdstreams();
2941 /*--------------------------------------------------------------------------------------*/
2943 #undef PerlIO_getname
2945 PerlIO_getname(PerlIO *f, char *buf)
2948 Perl_croak(aTHX_ "Don't know how to get file name");
2953 /*--------------------------------------------------------------------------------------*/
2954 /* Functions which can be called on any kind of PerlIO implemented
2960 PerlIO_getc(PerlIO *f)
2963 SSize_t count = PerlIO_read(f,buf,1);
2966 return (unsigned char) buf[0];
2971 #undef PerlIO_ungetc
2973 PerlIO_ungetc(PerlIO *f, int ch)
2978 if (PerlIO_unread(f,&buf,1) == 1)
2986 PerlIO_putc(PerlIO *f, int ch)
2989 return PerlIO_write(f,&buf,1);
2994 PerlIO_puts(PerlIO *f, const char *s)
2996 STRLEN len = strlen(s);
2997 return PerlIO_write(f,s,len);
3000 #undef PerlIO_rewind
3002 PerlIO_rewind(PerlIO *f)
3004 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3008 #undef PerlIO_vprintf
3010 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3013 SV *sv = newSVpvn("",0);
3018 Perl_va_copy(ap, apc);
3019 sv_vcatpvf(sv, fmt, &apc);
3021 sv_vcatpvf(sv, fmt, &ap);
3024 return PerlIO_write(f,s,len);
3027 #undef PerlIO_printf
3029 PerlIO_printf(PerlIO *f,const char *fmt,...)
3034 result = PerlIO_vprintf(f,fmt,ap);
3039 #undef PerlIO_stdoutf
3041 PerlIO_stdoutf(const char *fmt,...)
3046 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3051 #undef PerlIO_tmpfile
3053 PerlIO_tmpfile(void)
3055 /* I have no idea how portable mkstemp() is ... */
3056 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3059 FILE *stdio = PerlSIO_tmpfile();
3062 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
3068 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3069 int fd = mkstemp(SvPVX(sv));
3073 f = PerlIO_fdopen(fd,"w+");
3076 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3078 PerlLIO_unlink(SvPVX(sv));
3088 #endif /* USE_SFIO */
3089 #endif /* PERLIO_IS_STDIO */
3091 /*======================================================================================*/
3092 /* Now some functions in terms of above which may be needed even if
3093 we are not in true PerlIO mode
3097 #undef PerlIO_setpos
3099 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3101 return PerlIO_seek(f,*pos,0);
3104 #ifndef PERLIO_IS_STDIO
3105 #undef PerlIO_setpos
3107 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3109 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3110 return fsetpos64(f, pos);
3112 return fsetpos(f, pos);
3119 #undef PerlIO_getpos
3121 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3123 *pos = PerlIO_tell(f);
3124 return *pos == -1 ? -1 : 0;
3127 #ifndef PERLIO_IS_STDIO
3128 #undef PerlIO_getpos
3130 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3132 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3133 return fgetpos64(f, pos);
3135 return fgetpos(f, pos);
3141 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3144 vprintf(char *pat, char *args)
3146 _doprnt(pat, args, stdout);
3147 return 0; /* wrong, but perl doesn't use the return value */
3151 vfprintf(FILE *fd, char *pat, char *args)
3153 _doprnt(pat, args, fd);
3154 return 0; /* wrong, but perl doesn't use the return value */
3159 #ifndef PerlIO_vsprintf
3161 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3163 int val = vsprintf(s, fmt, ap);
3166 if (strlen(s) >= (STRLEN)n)
3169 (void)PerlIO_puts(Perl_error_log,
3170 "panic: sprintf overflow - memory corrupted!\n");
3178 #ifndef PerlIO_sprintf
3180 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3185 result = PerlIO_vsprintf(s, n, fmt, ap);