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.
18 #define PERLIO_NOT_STDIO 0
19 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
20 /* #define PerlIO FILE */
23 * This file provides those parts of PerlIO abstraction
24 * which are not #defined in iperlsys.h.
25 * Which these are depends on various Configure #ifdef's
29 #define PERL_IN_PERLIO_C
32 #if !defined(PERL_IMPLICIT_SYS)
34 #ifdef PERLIO_IS_STDIO
39 /* Does nothing (yet) except force this file to be included
40 in perl binary. That allows this file to force inclusion
41 of other functions that may be required by loadable
42 extensions e.g. for FileHandle::tmpfile
53 #else /* PERLIO_IS_STDIO */
60 /* This section is just to make sure these functions
61 get pulled in from libsfio.a
74 /* Force this file to be included in perl binary. Which allows
75 * this file to force inclusion of other functions that may be
76 * required by loadable extensions e.g. for FileHandle::tmpfile
80 * sfio does its own 'autoflush' on stdout in common cases.
81 * Flush results in a lot of lseek()s to regular files and
82 * lot of small writes to pipes.
84 sfset(sfstdout,SF_SHARE,0);
89 /*======================================================================================*/
91 /* Implement all the PerlIO interface ourselves.
95 void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
99 PerlIO_debug(char *fmt,...)
104 char *s = getenv("PERLIO_DEBUG");
106 dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
114 SV *sv = newSVpvn("",0);
118 sv_vcatpvf(sv, fmt, &ap);
126 #define PERLIO_F_EOF 0x010000
127 #define PERLIO_F_ERROR 0x020000
128 #define PERLIO_F_LINEBUF 0x040000
129 #define PERLIO_F_TEMP 0x080000
130 #define PERLIO_F_RDBUF 0x100000
131 #define PERLIO_F_WRBUF 0x200000
132 #define PERLIO_F_OPEN 0x400000
133 #define PERLIO_F_USED 0x800000
138 IV fd; /* Maybe pointer on some OSes */
139 int oflags; /* open/fcntl flags */
140 STDCHAR *buf; /* Start of buffer */
141 STDCHAR *end; /* End of valid part of buffer */
142 STDCHAR *ptr; /* Current position in buffer */
143 Size_t bufsiz; /* Size of buffer */
144 Off_t posn; /* Offset of f->buf into the file */
148 int _perlio_size = 0;
149 PerlIO **_perlio = NULL;
152 PerlIO_alloc_buf(PerlIO *f)
156 New('B',f->buf,f->bufsiz,char);
159 f->buf = (STDCHAR *)&f->oneword;
160 f->bufsiz = sizeof(f->oneword);
164 PerlIO_debug(__FUNCTION__ " f=%p b=%p p=%p e=%p\n",
165 f,f->buf,f->ptr,f->end);
170 PerlIO_flush(PerlIO *f)
175 PerlIO_debug(__FUNCTION__ " f=%p flags=%08X c=%d buf=%p ptr=%p\n",
176 f,f->flags,(f->ptr-f->buf),f->buf,f->ptr);
177 if (f->flags & PERLIO_F_WRBUF)
183 count = write(f->fd,p,f->ptr - p);
188 else if (count < 0 && errno != EINTR)
190 f->flags |= PERLIO_F_ERROR;
195 f->posn += (p - f->buf);
196 PerlIO_debug(__FUNCTION__ "(w) f=%p p=%ld\n",f,(long)f->posn);
198 else if (f->flags & PERLIO_F_RDBUF)
200 f->posn += (f->ptr - f->buf);
203 f->posn = lseek(f->fd,f->posn,SEEK_SET);
205 PerlIO_debug(__FUNCTION__ "(r+) f=%p p=%ld\n",f,(long)f->posn);
209 PerlIO_debug(__FUNCTION__ "(?) f=%p p=%ld\n",f,(long)f->posn);
211 f->ptr = f->end = f->buf;
212 f->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
217 for (i=_perlio_size; i >= 0; i--)
219 if ((f = _perlio[i]))
221 if (PerlIO_flush(f) != 0)
230 PerlIO_oflags(const char *mode)
233 PerlIO_debug(__FUNCTION__ " %s = ",mode);
246 oflags = O_CREAT|O_TRUNC;
257 oflags = O_CREAT|O_APPEND;
267 if (*mode || oflags == -1)
272 PerlIO_debug(" %X '%s'\n",oflags,mode);
277 PerlIO_allocate(void)
283 PerlIO **table = _perlio;
284 while (i < _perlio_size)
287 PerlIO_debug(__FUNCTION__ " try %d %p\n",i,f);
290 Newz('F',f,1,PerlIO);
295 if (!(f->flags & PERLIO_F_USED))
298 f->flags = PERLIO_F_USED;
303 Newz('I',table,_perlio_size+16,PerlIO *);
306 Copy(_perlio,table,_perlio_size,PerlIO *);
316 PerlIO_fdopen(int fd, const char *mode)
321 if ((f = PerlIO_allocate()))
324 f->oflags = PerlIO_oflags(mode);
325 f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED);
328 PerlIO_debug(__FUNCTION__ " fd=%d m=%s f=%p\n",fd,mode,f);
334 PerlIO_fileno(PerlIO *f)
336 if (f && (f->flags & PERLIO_F_OPEN))
345 PerlIO_close(PerlIO *f)
350 if (PerlIO_flush(f) != 0)
352 while (close(f->fd) != 0)
360 f->flags &= ~PERLIO_F_OPEN;
362 if (f->buf && f->buf != (STDCHAR *) &f->oneword)
367 f->ptr = f->end = f->buf;
368 f->flags &= ~(PERLIO_F_USED|PERLIO_F_RDBUF|PERLIO_F_WRBUF);
377 PerlIO_debug(__FUNCTION__ "\n");
378 for (i=_perlio_size-1; i >= 0; i--)
380 PerlIO *f = _perlio[i];
395 PerlIO_open(const char *path, const char *mode)
398 int oflags = PerlIO_oflags(mode);
401 int fd = open(path,oflags,0666);
404 PerlIO_debug(__FUNCTION__ "fd=%d\n",fd);
405 f = PerlIO_fdopen(fd,mode);
410 PerlIO_debug(__FUNCTION__ " path=%s m=%s f=%p\n",path,mode,f);
416 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
418 PerlIO_debug(__FUNCTION__ " n=%s m=%s f=%p\n",path,mode,f);
421 int oflags = PerlIO_oflags(mode);
425 int fd = open(path,oflags,0666);
428 PerlIO_debug(__FUNCTION__ "fd=%d\n",fd);
430 f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED);
438 return PerlIO_open(path,mode);
446 atexit(&PerlIO_cleanup);
447 PerlIO_fdopen(0,"r");
448 PerlIO_fdopen(1,"w");
449 PerlIO_fdopen(2,"w");
451 PerlIO_debug(__FUNCTION__ "\n");
481 #undef PerlIO_fast_gets
483 PerlIO_fast_gets(PerlIO *f)
488 #undef PerlIO_has_cntptr
490 PerlIO_has_cntptr(PerlIO *f)
495 #undef PerlIO_canset_cnt
497 PerlIO_canset_cnt(PerlIO *f)
502 #undef PerlIO_set_cnt
504 PerlIO_set_cnt(PerlIO *f, int cnt)
511 f->ptr = f->end - cnt;
512 assert(f->ptr >= f->buf);
516 #undef PerlIO_get_cnt
518 PerlIO_get_cnt(PerlIO *f)
524 if (f->flags & PERLIO_F_RDBUF)
525 return (f->end - f->ptr);
530 #undef PerlIO_set_ptrcnt
532 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
540 assert(f->ptr >= f->buf);
541 if (PerlIO_get_cnt(f) != cnt)
544 assert(PerlIO_get_cnt(f) != cnt);
546 f->flags |= PERLIO_F_RDBUF;
550 #undef PerlIO_get_bufsiz
552 PerlIO_get_bufsiz(PerlIO *f)
563 #undef PerlIO_get_ptr
565 PerlIO_get_ptr(PerlIO *f)
576 #undef PerlIO_get_base
578 PerlIO_get_base(PerlIO *f)
589 #undef PerlIO_has_base
591 PerlIO_has_base(PerlIO *f)
597 return f->buf != NULL;
603 PerlIO_puts(PerlIO *f, const char *s)
605 STRLEN len = strlen(s);
606 return PerlIO_write(f,s,len);
611 PerlIO_eof(PerlIO *f)
615 return (f->flags & PERLIO_F_EOF) != 0;
620 #undef PerlIO_getname
622 PerlIO_getname(PerlIO *f, char *buf)
625 return fgetname(f,buf);
628 Perl_croak(aTHX_ "Don't know how to get file name");
635 PerlIO_ungetc(PerlIO *f, int ch)
637 if (f->buf && (f->flags & PERLIO_F_RDBUF) && f->ptr > f->buf)
640 PerlIO_debug(__FUNCTION__ " f=%p c=%c\n",f,ch);
643 PerlIO_debug(__FUNCTION__ " f=%p c=%c - cannot\n",f,ch);
649 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
651 STDCHAR *buf = (STDCHAR *) vbuf;
660 SSize_t avail = (f->end - f->ptr);
661 if ((SSize_t) count < avail)
665 Copy(f->ptr,buf,avail,char);
671 if (count && (f->ptr >= f->end))
674 f->ptr = f->end = f->buf;
675 avail = read(f->fd,f->ptr,f->bufsiz);
679 f->flags |= PERLIO_F_EOF;
680 else if (errno == EINTR)
683 f->flags |= PERLIO_F_ERROR;
686 f->end = f->buf+avail;
687 f->flags |= PERLIO_F_RDBUF;
697 PerlIO_getc(PerlIO *f)
700 int count = PerlIO_read(f,&buf,1);
708 PerlIO_error(PerlIO *f)
712 return f->flags & PERLIO_F_ERROR;
717 #undef PerlIO_clearerr
719 PerlIO_clearerr(PerlIO *f)
723 f->flags &= ~PERLIO_F_ERROR;
727 #undef PerlIO_setlinebuf
729 PerlIO_setlinebuf(PerlIO *f)
733 f->flags &= ~PERLIO_F_LINEBUF;
739 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
741 const STDCHAR *buf = (const STDCHAR *) vbuf;
743 PerlIO_debug(__FUNCTION__ " f=%p c=%d\n",f,count);
750 SSize_t avail = f->bufsiz - (f->ptr - f->buf);
751 if ((SSize_t) count < avail)
753 f->flags |= PERLIO_F_WRBUF;
754 if (1 || (f->flags & PERLIO_F_LINEBUF))
774 Copy(buf,f->ptr,avail,char);
781 if (f->ptr >= (f->buf + f->bufsiz))
790 PerlIO_putc(PerlIO *f, int ch)
793 PerlIO_write(f,&ch,1);
798 PerlIO_tell(PerlIO *f)
800 Off_t posn = f->posn;
802 posn += (f->ptr - f->buf);
803 PerlIO_debug(__FUNCTION__ " f=%p r=%ld b=%p p=%p e=%ld\n",
804 f,(long)f->posn,f->buf,f->ptr,(long)posn);
810 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
813 PerlIO_debug(__FUNCTION__ " f=%p i=%ld+%d\n",f,(long)f->posn,(f->ptr-f->buf));
814 code = PerlIO_flush(f);
817 f->flags &= ~PERLIO_F_EOF;
818 f->posn = PerlLIO_lseek(f->fd,offset,whence);
819 PerlIO_debug(__FUNCTION__ " f=%p o=%ld w=%d p=%ld\n",
820 f,(long)offset,whence,(long)f->posn);
821 if (f->posn == (Off_t) -1)
832 PerlIO_rewind(PerlIO *f)
834 PerlIO_seek(f,(Off_t)0,SEEK_SET);
837 #undef PerlIO_vprintf
839 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
842 SV *sv = newSVpvn("",0);
845 sv_vcatpvf(sv, fmt, &ap);
847 return PerlIO_write(f,s,len);
852 PerlIO_printf(PerlIO *f,const char *fmt,...)
857 result = PerlIO_vprintf(f,fmt,ap);
862 #undef PerlIO_stdoutf
864 PerlIO_stdoutf(const char *fmt,...)
869 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
874 #undef PerlIO_tmpfile
879 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
880 int fd = mkstemp(SvPVX(sv));
884 PerlIO *f = PerlIO_fdopen(fd,"w+");
887 f->flags |= PERLIO_F_TEMP;
895 #undef PerlIO_importFILE
897 PerlIO_importFILE(FILE *f, int fl)
900 return PerlIO_fdopen(fd,"r+");
903 #undef PerlIO_exportFILE
905 PerlIO_exportFILE(PerlIO *f, int fl)
908 return fdopen(PerlIO_fileno(f),"r+");
911 #undef PerlIO_findFILE
913 PerlIO_findFILE(PerlIO *f)
915 return PerlIO_exportFILE(f,0);
918 #undef PerlIO_releaseFILE
920 PerlIO_releaseFILE(PerlIO *p, FILE *f)
927 /*======================================================================================*/
929 #endif /* USE_SFIO */
930 #endif /* PERLIO_IS_STDIO */
935 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
937 return PerlIO_seek(f,*pos,0);
940 #ifndef PERLIO_IS_STDIO
943 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
945 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
946 return fsetpos64(f, pos);
948 return fsetpos(f, pos);
957 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
959 *pos = PerlIO_tell(f);
963 #ifndef PERLIO_IS_STDIO
966 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
968 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
969 return fgetpos64(f, pos);
971 return fgetpos(f, pos);
977 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
980 vprintf(char *pat, char *args)
982 _doprnt(pat, args, stdout);
983 return 0; /* wrong, but perl doesn't use the return value */
987 vfprintf(FILE *fd, char *pat, char *args)
989 _doprnt(pat, args, fd);
990 return 0; /* wrong, but perl doesn't use the return value */
995 #ifndef PerlIO_vsprintf
997 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
999 int val = vsprintf(s, fmt, ap);
1002 if (strlen(s) >= (STRLEN)n)
1005 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1013 #ifndef PerlIO_sprintf
1015 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1020 result = PerlIO_vsprintf(s, n, fmt, ap);
1026 #endif /* !PERL_IMPLICIT_SYS */