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 iperlsys.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #if !defined(PERL_IMPLICIT_SYS)
33 #ifdef PERLIO_IS_STDIO
38 /* Does nothing (yet) except force this file to be included
39 in perl binary. That allows this file to force inclusion
40 of other functions that may be required by loadable
41 extensions e.g. for FileHandle::tmpfile
52 #else /* PERLIO_IS_STDIO */
59 /* This section is just to make sure these functions
60 get pulled in from libsfio.a
73 /* Force this file to be included in perl binary. Which allows
74 * this file to force inclusion of other functions that may be
75 * required by loadable extensions e.g. for FileHandle::tmpfile
79 * sfio does its own 'autoflush' on stdout in common cases.
80 * Flush results in a lot of lseek()s to regular files and
81 * lot of small writes to pipes.
83 sfset(sfstdout,SF_SHARE,0);
88 /*======================================================================================*/
90 /* Implement all the PerlIO interface ourselves.
93 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
99 void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
102 PerlIO_debug(char *fmt,...)
107 char *s = getenv("PERLIO_DEBUG");
109 dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
117 SV *sv = newSVpvn("",0);
121 sv_vcatpvf(sv, fmt, &ap);
129 #define PERLIO_F_EOF 0x010000
130 #define PERLIO_F_ERROR 0x020000
131 #define PERLIO_F_LINEBUF 0x040000
132 #define PERLIO_F_TEMP 0x080000
133 #define PERLIO_F_RDBUF 0x100000
134 #define PERLIO_F_WRBUF 0x200000
135 #define PERLIO_F_OPEN 0x400000
136 #define PERLIO_F_USED 0x800000
140 IV flags; /* Various flags for state */
141 IV fd; /* Maybe pointer on some OSes */
142 int oflags; /* open/fcntl flags */
143 STDCHAR *buf; /* Start of buffer */
144 STDCHAR *end; /* End of valid part of buffer */
145 STDCHAR *ptr; /* Current position in buffer */
146 Size_t bufsiz; /* Size of buffer */
147 Off_t posn; /* Offset of f->buf into the file */
148 int oneword; /* An if-all-else-fails area as a buffer */
151 /* Table of pointers to the PerlIO structs (malloc'ed) */
152 PerlIO **_perlio = NULL;
153 int _perlio_size = 0;
156 PerlIO_alloc_buf(PerlIO *f)
160 New('B',f->buf,f->bufsiz,char);
163 f->buf = (STDCHAR *)&f->oneword;
164 f->bufsiz = sizeof(f->oneword);
171 /* This "flush" is akin to sfio's sync in that it handles files in either
176 PerlIO_flush(PerlIO *f)
181 if (f->flags & PERLIO_F_WRBUF)
183 /* write() the buffer */
188 count = write(f->fd,p,f->ptr - p);
193 else if (count < 0 && errno != EINTR)
195 f->flags |= PERLIO_F_ERROR;
200 f->posn += (p - f->buf);
202 else if (f->flags & PERLIO_F_RDBUF)
204 /* Note position change */
205 f->posn += (f->ptr - f->buf);
208 /* We did not consume all of it */
209 f->posn = lseek(f->fd,f->posn,SEEK_SET);
212 f->ptr = f->end = f->buf;
213 f->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
218 for (i=_perlio_size-1; i >= 0; i--)
220 if ((f = _perlio[i]))
222 if (PerlIO_flush(f) != 0)
231 PerlIO_oflags(const char *mode)
246 oflags = O_CREAT|O_TRUNC;
257 oflags = O_CREAT|O_APPEND;
267 if (*mode || oflags == -1)
276 PerlIO_allocate(void)
278 /* Find a free slot in the table, growing table as necessary */
283 PerlIO **table = _perlio;
284 while (i < _perlio_size)
289 Newz('F',f,1,PerlIO);
294 if (!(f->flags & PERLIO_F_USED))
297 f->flags = PERLIO_F_USED;
302 Newz('I',table,_perlio_size+16,PerlIO *);
305 Copy(_perlio,table,_perlio_size,PerlIO *);
315 PerlIO_fdopen(int fd, const char *mode)
320 if ((f = PerlIO_allocate()))
323 f->oflags = PerlIO_oflags(mode);
324 f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED);
332 PerlIO_fileno(PerlIO *f)
334 if (f && (f->flags & PERLIO_F_OPEN))
343 PerlIO_close(PerlIO *f)
348 if (PerlIO_flush(f) != 0)
350 while (close(f->fd) != 0)
358 f->flags &= ~PERLIO_F_OPEN;
360 if (f->buf && f->buf != (STDCHAR *) &f->oneword)
365 f->ptr = f->end = f->buf;
366 f->flags &= ~(PERLIO_F_USED|PERLIO_F_RDBUF|PERLIO_F_WRBUF);
374 /* Close all the files */
376 for (i=_perlio_size-1; i >= 0; i--)
378 PerlIO *f = _perlio[i];
393 PerlIO_open(const char *path, const char *mode)
396 int oflags = PerlIO_oflags(mode);
399 int fd = open(path,oflags,0666);
402 f = PerlIO_fdopen(fd,mode);
412 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
416 int oflags = PerlIO_oflags(mode);
420 int fd = open(path,oflags,0666);
424 f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED);
432 return PerlIO_open(path,mode);
440 atexit(&PerlIO_cleanup);
441 PerlIO_fdopen(0,"r");
442 PerlIO_fdopen(1,"w");
443 PerlIO_fdopen(2,"w");
474 #undef PerlIO_fast_gets
476 PerlIO_fast_gets(PerlIO *f)
481 #undef PerlIO_has_cntptr
483 PerlIO_has_cntptr(PerlIO *f)
488 #undef PerlIO_canset_cnt
490 PerlIO_canset_cnt(PerlIO *f)
495 #undef PerlIO_set_cnt
497 PerlIO_set_cnt(PerlIO *f, int cnt)
504 f->ptr = f->end - cnt;
505 assert(f->ptr >= f->buf);
509 #undef PerlIO_get_cnt
511 PerlIO_get_cnt(PerlIO *f)
517 if (f->flags & PERLIO_F_RDBUF)
518 return (f->end - f->ptr);
523 #undef PerlIO_set_ptrcnt
525 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
532 if (PerlIO_get_cnt(f) != cnt || f->ptr < f->buf)
535 assert(PerlIO_get_cnt(f) == cnt);
536 assert(f->ptr >= f->buf);
538 f->flags |= PERLIO_F_RDBUF;
542 #undef PerlIO_get_bufsiz
544 PerlIO_get_bufsiz(PerlIO *f)
555 #undef PerlIO_get_ptr
557 PerlIO_get_ptr(PerlIO *f)
568 #undef PerlIO_get_base
570 PerlIO_get_base(PerlIO *f)
581 #undef PerlIO_has_base
583 PerlIO_has_base(PerlIO *f)
589 return f->buf != NULL;
595 PerlIO_puts(PerlIO *f, const char *s)
597 STRLEN len = strlen(s);
598 return PerlIO_write(f,s,len);
603 PerlIO_eof(PerlIO *f)
607 return (f->flags & PERLIO_F_EOF) != 0;
612 #undef PerlIO_getname
614 PerlIO_getname(PerlIO *f, char *buf)
617 Perl_croak(aTHX_ "Don't know how to get file name");
623 PerlIO_ungetc(PerlIO *f, int ch)
625 if (f->buf && (f->flags & PERLIO_F_RDBUF) && f->ptr > f->buf)
635 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
637 STDCHAR *buf = (STDCHAR *) vbuf;
643 if ((f->oflags & (O_RDONLY|O_WRONLY|O_RDWR)) == O_WRONLY)
647 SSize_t avail = (f->end - f->ptr);
648 if ((SSize_t) count < avail)
652 Copy(f->ptr,buf,avail,char);
658 if (count && (f->ptr >= f->end))
661 f->ptr = f->end = f->buf;
662 avail = read(f->fd,f->ptr,f->bufsiz);
666 f->flags |= PERLIO_F_EOF;
667 else if (errno == EINTR)
670 f->flags |= PERLIO_F_ERROR;
673 f->end = f->buf+avail;
674 f->flags |= PERLIO_F_RDBUF;
684 PerlIO_getc(PerlIO *f)
687 int count = PerlIO_read(f,&buf,1);
689 return (unsigned char) buf;
695 PerlIO_error(PerlIO *f)
699 return f->flags & PERLIO_F_ERROR;
704 #undef PerlIO_clearerr
706 PerlIO_clearerr(PerlIO *f)
710 f->flags &= ~PERLIO_F_ERROR;
714 #undef PerlIO_setlinebuf
716 PerlIO_setlinebuf(PerlIO *f)
720 f->flags &= ~PERLIO_F_LINEBUF;
726 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
728 const STDCHAR *buf = (const STDCHAR *) vbuf;
734 if ((f->oflags & (O_RDONLY|O_WRONLY|O_RDWR)) == O_RDONLY)
738 SSize_t avail = f->bufsiz - (f->ptr - f->buf);
739 if ((SSize_t) count < avail)
741 f->flags |= PERLIO_F_WRBUF;
742 if (f->flags & PERLIO_F_LINEBUF)
762 Copy(buf,f->ptr,avail,char);
769 if (f->ptr >= (f->buf + f->bufsiz))
778 PerlIO_putc(PerlIO *f, int ch)
781 PerlIO_write(f,&buf,1);
786 PerlIO_tell(PerlIO *f)
788 Off_t posn = f->posn;
790 posn += (f->ptr - f->buf);
796 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
799 code = PerlIO_flush(f);
802 f->flags &= ~PERLIO_F_EOF;
803 f->posn = PerlLIO_lseek(f->fd,offset,whence);
804 if (f->posn == (Off_t) -1)
815 PerlIO_rewind(PerlIO *f)
817 PerlIO_seek(f,(Off_t)0,SEEK_SET);
820 #undef PerlIO_vprintf
822 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
825 SV *sv = newSVpvn("",0);
828 sv_vcatpvf(sv, fmt, &ap);
830 return PerlIO_write(f,s,len);
835 PerlIO_printf(PerlIO *f,const char *fmt,...)
840 result = PerlIO_vprintf(f,fmt,ap);
845 #undef PerlIO_stdoutf
847 PerlIO_stdoutf(const char *fmt,...)
852 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
857 #undef PerlIO_tmpfile
862 /* I have no idea how portable mkstemp() is ... */
863 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
864 int fd = mkstemp(SvPVX(sv));
868 f = PerlIO_fdopen(fd,"w+");
871 f->flags |= PERLIO_F_TEMP;
879 #undef PerlIO_importFILE
881 PerlIO_importFILE(FILE *f, int fl)
884 /* Should really push stdio discipline when we have them */
885 return PerlIO_fdopen(fd,"r+");
888 #undef PerlIO_exportFILE
890 PerlIO_exportFILE(PerlIO *f, int fl)
893 /* Should really push stdio discipline when we have them */
894 return fdopen(PerlIO_fileno(f),"r+");
897 #undef PerlIO_findFILE
899 PerlIO_findFILE(PerlIO *f)
901 return PerlIO_exportFILE(f,0);
904 #undef PerlIO_releaseFILE
906 PerlIO_releaseFILE(PerlIO *p, FILE *f)
913 /*======================================================================================*/
915 #endif /* USE_SFIO */
916 #endif /* PERLIO_IS_STDIO */
921 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
923 return PerlIO_seek(f,*pos,0);
926 #ifndef PERLIO_IS_STDIO
929 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
931 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
932 return fsetpos64(f, pos);
934 return fsetpos(f, pos);
943 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
945 *pos = PerlIO_tell(f);
949 #ifndef PERLIO_IS_STDIO
952 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
954 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
955 return fgetpos64(f, pos);
957 return fgetpos(f, pos);
963 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
966 vprintf(char *pat, char *args)
968 _doprnt(pat, args, stdout);
969 return 0; /* wrong, but perl doesn't use the return value */
973 vfprintf(FILE *fd, char *pat, char *args)
975 _doprnt(pat, args, fd);
976 return 0; /* wrong, but perl doesn't use the return value */
981 #ifndef PerlIO_vsprintf
983 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
985 int val = vsprintf(s, fmt, ap);
988 if (strlen(s) >= (STRLEN)n)
991 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
999 #ifndef PerlIO_sprintf
1001 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1006 result = PerlIO_vsprintf(s, n, fmt, ap);
1012 #endif /* !PERL_IMPLICIT_SYS */