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 PerlIO_debug(__FUNCTION__ " f=%p flags=%08X c=%d buf=%p ptr=%p\n",
182 f,f->flags,(f->ptr-f->buf),f->buf,f->ptr);
183 if (f->flags & PERLIO_F_WRBUF)
185 /* write() the buffer */
190 count = write(f->fd,p,f->ptr - p);
195 else if (count < 0 && errno != EINTR)
197 f->flags |= PERLIO_F_ERROR;
202 f->posn += (p - f->buf);
204 else if (f->flags & PERLIO_F_RDBUF)
206 /* Note position change */
207 f->posn += (f->ptr - f->buf);
210 /* We did not consume all of it */
211 f->posn = lseek(f->fd,f->posn,SEEK_SET);
214 f->ptr = f->end = f->buf;
215 f->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
220 for (i=_perlio_size; i >= 0; i--)
222 if ((f = _perlio[i]))
224 if (PerlIO_flush(f) != 0)
233 PerlIO_oflags(const char *mode)
236 PerlIO_debug(__FUNCTION__ " %s = ",mode);
249 oflags = O_CREAT|O_TRUNC;
260 oflags = O_CREAT|O_APPEND;
270 if (*mode || oflags == -1)
275 PerlIO_debug(" %X '%s'\n",oflags,mode);
280 PerlIO_allocate(void)
282 /* Find a free slot in the table, growing table as necessary */
287 PerlIO **table = _perlio;
288 while (i < _perlio_size)
291 PerlIO_debug(__FUNCTION__ " try %d %p\n",i,f);
294 Newz('F',f,1,PerlIO);
299 if (!(f->flags & PERLIO_F_USED))
302 f->flags = PERLIO_F_USED;
307 Newz('I',table,_perlio_size+16,PerlIO *);
310 Copy(_perlio,table,_perlio_size,PerlIO *);
320 PerlIO_fdopen(int fd, const char *mode)
325 if ((f = PerlIO_allocate()))
328 f->oflags = PerlIO_oflags(mode);
329 f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED);
332 PerlIO_debug(__FUNCTION__ " fd=%d m=%s f=%p\n",fd,mode,f);
338 PerlIO_fileno(PerlIO *f)
340 if (f && (f->flags & PERLIO_F_OPEN))
349 PerlIO_close(PerlIO *f)
354 if (PerlIO_flush(f) != 0)
356 while (close(f->fd) != 0)
364 f->flags &= ~PERLIO_F_OPEN;
366 if (f->buf && f->buf != (STDCHAR *) &f->oneword)
371 f->ptr = f->end = f->buf;
372 f->flags &= ~(PERLIO_F_USED|PERLIO_F_RDBUF|PERLIO_F_WRBUF);
380 /* Close all the files */
382 PerlIO_debug(__FUNCTION__ "\n");
383 for (i=_perlio_size-1; i >= 0; i--)
385 PerlIO *f = _perlio[i];
400 PerlIO_open(const char *path, const char *mode)
403 int oflags = PerlIO_oflags(mode);
406 int fd = open(path,oflags,0666);
409 PerlIO_debug(__FUNCTION__ "fd=%d\n",fd);
410 f = PerlIO_fdopen(fd,mode);
415 PerlIO_debug(__FUNCTION__ " path=%s m=%s f=%p\n",path,mode,f);
421 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
423 PerlIO_debug(__FUNCTION__ " n=%s m=%s f=%p\n",path,mode,f);
426 int oflags = PerlIO_oflags(mode);
430 int fd = open(path,oflags,0666);
433 PerlIO_debug(__FUNCTION__ "fd=%d\n",fd);
435 f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED);
443 return PerlIO_open(path,mode);
451 atexit(&PerlIO_cleanup);
452 PerlIO_fdopen(0,"r");
453 PerlIO_fdopen(1,"w");
454 PerlIO_fdopen(2,"w");
456 PerlIO_debug(__FUNCTION__ "\n");
486 #undef PerlIO_fast_gets
488 PerlIO_fast_gets(PerlIO *f)
493 #undef PerlIO_has_cntptr
495 PerlIO_has_cntptr(PerlIO *f)
500 #undef PerlIO_canset_cnt
502 PerlIO_canset_cnt(PerlIO *f)
507 #undef PerlIO_set_cnt
509 PerlIO_set_cnt(PerlIO *f, int cnt)
516 f->ptr = f->end - cnt;
517 assert(f->ptr >= f->buf);
521 #undef PerlIO_get_cnt
523 PerlIO_get_cnt(PerlIO *f)
529 if (f->flags & PERLIO_F_RDBUF)
530 return (f->end - f->ptr);
535 #undef PerlIO_set_ptrcnt
537 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
544 if (PerlIO_get_cnt(f) != cnt || f->ptr < f->buf)
547 assert(PerlIO_get_cnt(f) == cnt);
548 assert(f->ptr >= f->buf);
550 f->flags |= PERLIO_F_RDBUF;
554 #undef PerlIO_get_bufsiz
556 PerlIO_get_bufsiz(PerlIO *f)
567 #undef PerlIO_get_ptr
569 PerlIO_get_ptr(PerlIO *f)
580 #undef PerlIO_get_base
582 PerlIO_get_base(PerlIO *f)
593 #undef PerlIO_has_base
595 PerlIO_has_base(PerlIO *f)
601 return f->buf != NULL;
607 PerlIO_puts(PerlIO *f, const char *s)
609 STRLEN len = strlen(s);
610 return PerlIO_write(f,s,len);
615 PerlIO_eof(PerlIO *f)
619 return (f->flags & PERLIO_F_EOF) != 0;
624 #undef PerlIO_getname
626 PerlIO_getname(PerlIO *f, char *buf)
629 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)
642 PerlIO_debug(__FUNCTION__ " f=%p c=%c - cannot\n",f,ch);
648 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
650 STDCHAR *buf = (STDCHAR *) vbuf;
659 SSize_t avail = (f->end - f->ptr);
660 if ((SSize_t) count < avail)
664 Copy(f->ptr,buf,avail,char);
670 if (count && (f->ptr >= f->end))
673 f->ptr = f->end = f->buf;
674 avail = read(f->fd,f->ptr,f->bufsiz);
678 f->flags |= PERLIO_F_EOF;
679 else if (errno == EINTR)
682 f->flags |= PERLIO_F_ERROR;
685 f->end = f->buf+avail;
686 f->flags |= PERLIO_F_RDBUF;
696 PerlIO_getc(PerlIO *f)
699 int count = PerlIO_read(f,&buf,1);
701 return (unsigned char) buf;
707 PerlIO_error(PerlIO *f)
711 return f->flags & PERLIO_F_ERROR;
716 #undef PerlIO_clearerr
718 PerlIO_clearerr(PerlIO *f)
722 f->flags &= ~PERLIO_F_ERROR;
726 #undef PerlIO_setlinebuf
728 PerlIO_setlinebuf(PerlIO *f)
732 f->flags &= ~PERLIO_F_LINEBUF;
738 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
740 const STDCHAR *buf = (const STDCHAR *) vbuf;
742 PerlIO_debug(__FUNCTION__ " f=%p c=%d\n",f,count);
749 SSize_t avail = f->bufsiz - (f->ptr - f->buf);
750 if ((SSize_t) count < avail)
752 f->flags |= PERLIO_F_WRBUF;
753 if (f->flags & PERLIO_F_LINEBUF)
773 Copy(buf,f->ptr,avail,char);
780 if (f->ptr >= (f->buf + f->bufsiz))
789 PerlIO_putc(PerlIO *f, int ch)
792 PerlIO_write(f,&ch,1);
797 PerlIO_tell(PerlIO *f)
799 Off_t posn = f->posn;
801 posn += (f->ptr - f->buf);
802 PerlIO_debug(__FUNCTION__ " f=%p b=%ld a=%ld\n",f,(long)f->posn,(long)posn);
808 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
811 PerlIO_debug(__FUNCTION__ " f=%p i=%ld+%d\n",f,(long)f->posn,(f->ptr-f->buf));
812 code = PerlIO_flush(f);
815 f->flags &= ~PERLIO_F_EOF;
816 f->posn = PerlLIO_lseek(f->fd,offset,whence);
817 PerlIO_debug(__FUNCTION__ " f=%p o=%ld w=%d p=%ld\n",
818 f,(long)offset,whence,(long)f->posn);
819 if (f->posn == (Off_t) -1)
830 PerlIO_rewind(PerlIO *f)
832 PerlIO_seek(f,(Off_t)0,SEEK_SET);
835 #undef PerlIO_vprintf
837 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
840 SV *sv = newSVpvn("",0);
843 sv_vcatpvf(sv, fmt, &ap);
845 return PerlIO_write(f,s,len);
850 PerlIO_printf(PerlIO *f,const char *fmt,...)
855 result = PerlIO_vprintf(f,fmt,ap);
860 #undef PerlIO_stdoutf
862 PerlIO_stdoutf(const char *fmt,...)
867 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
872 #undef PerlIO_tmpfile
877 /* I have no idea how portable mkstemp() is ... */
878 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
879 int fd = mkstemp(SvPVX(sv));
883 f = PerlIO_fdopen(fd,"w+");
886 f->flags |= PERLIO_F_TEMP;
894 #undef PerlIO_importFILE
896 PerlIO_importFILE(FILE *f, int fl)
899 /* Should really push stdio discipline when we have them */
900 return PerlIO_fdopen(fd,"r+");
903 #undef PerlIO_exportFILE
905 PerlIO_exportFILE(PerlIO *f, int fl)
908 /* Should really push stdio discipline when we have them */
909 return fdopen(PerlIO_fileno(f),"r+");
912 #undef PerlIO_findFILE
914 PerlIO_findFILE(PerlIO *f)
916 return PerlIO_exportFILE(f,0);
919 #undef PerlIO_releaseFILE
921 PerlIO_releaseFILE(PerlIO *p, FILE *f)
928 /*======================================================================================*/
930 #endif /* USE_SFIO */
931 #endif /* PERLIO_IS_STDIO */
936 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
938 return PerlIO_seek(f,*pos,0);
941 #ifndef PERLIO_IS_STDIO
944 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
946 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
947 return fsetpos64(f, pos);
949 return fsetpos(f, pos);
958 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
960 *pos = PerlIO_tell(f);
964 #ifndef PERLIO_IS_STDIO
967 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
969 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
970 return fgetpos64(f, pos);
972 return fgetpos(f, pos);
978 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
981 vprintf(char *pat, char *args)
983 _doprnt(pat, args, stdout);
984 return 0; /* wrong, but perl doesn't use the return value */
988 vfprintf(FILE *fd, char *pat, char *args)
990 _doprnt(pat, args, fd);
991 return 0; /* wrong, but perl doesn't use the return value */
996 #ifndef PerlIO_vsprintf
998 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1000 int val = vsprintf(s, fmt, ap);
1003 if (strlen(s) >= (STRLEN)n)
1006 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1014 #ifndef PerlIO_sprintf
1016 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1021 result = PerlIO_vsprintf(s, n, fmt, ap);
1027 #endif /* !PERL_IMPLICIT_SYS */