From: Nick Ing-Simmons Date: Sun, 29 Oct 2000 11:18:16 +0000 (+0000) Subject: Prototype (stdio-like) PerlIO passing basic tests. Checked in X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6f9d8c32c6a78a47c6088f50d7051d779f712ee1;p=p5sagit%2Fp5-mst-13.2.git Prototype (stdio-like) PerlIO passing basic tests. Checked in in case of accidents. Still several worrying fails, no line disciplines yet. p4raw-id: //depot/perlio@7479 --- diff --git a/iperlsys.h b/iperlsys.h index 59da474..9357e0e 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -120,7 +120,7 @@ typedef void (*LPSetCnt)(struct IPerlStdIO*, PerlIO*, int); typedef void (*LPSetPtrCnt)(struct IPerlStdIO*, PerlIO*, char*, int); typedef void (*LPSetlinebuf)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPPrintf)(struct IPerlStdIO*, PerlIO*, const char*, +typedef int (*LPPrintf)(struct IPerlStdIO*, PerlIO*, const char*, ...); typedef int (*LPVprintf)(struct IPerlStdIO*, PerlIO*, const char*, va_list); @@ -185,14 +185,14 @@ struct IPerlStdIOInfo }; #ifdef USE_STDIO_PTR -# define PerlIO_has_cntptr(f) 1 +# define PerlIO_has_cntptr(f) 1 # ifdef STDIO_CNT_LVALUE -# define PerlIO_canset_cnt(f) 1 +# define PerlIO_canset_cnt(f) 1 # ifdef STDIO_PTR_LVALUE -# define PerlIO_fast_gets(f) 1 +# define PerlIO_fast_gets(f) 1 # endif # else -# define PerlIO_canset_cnt(f) 0 +# define PerlIO_canset_cnt(f) 0 # endif #else /* USE_STDIO_PTR */ # define PerlIO_has_cntptr(f) 0 @@ -200,7 +200,7 @@ struct IPerlStdIOInfo #endif /* USE_STDIO_PTR */ #ifndef PerlIO_fast_gets -#define PerlIO_fast_gets(f) 0 +#define PerlIO_fast_gets(f) 0 #endif #ifdef FILE_base @@ -268,7 +268,7 @@ struct IPerlStdIOInfo #define PerlIO_printf Perl_fprintf_nocontext #define PerlIO_stdoutf *PL_StdIO->pPrintf #define PerlIO_vprintf(f,fmt,a) \ - (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) + (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) #define PerlIO_tell(f) \ (*PL_StdIO->pTell)(PL_StdIO, (f)) #define PerlIO_seek(f,o,w) \ @@ -325,8 +325,8 @@ struct IPerlStdIOInfo #endif #ifndef PerlIO -struct _PerlIO; -#define PerlIO struct _PerlIO +typedef struct _PerlIO PerlIO; +#define PerlIO PerlIO #endif /* No PerlIO */ #ifndef Fpos_t @@ -552,7 +552,7 @@ struct IPerlDirInfo #define PerlDir_mkdir(name, mode) Mkdir((name), (mode)) #ifdef VMS # define PerlDir_chdir(n) Chdir(((n) && *(n)) ? (n) : "SYS$LOGIN") -#else +#else # define PerlDir_chdir(name) chdir((name)) #endif #define PerlDir_rmdir(name) rmdir((name)) @@ -1256,7 +1256,7 @@ typedef int (*LPRecvfrom)(struct IPerlSock*, SOCKET, char*, int, typedef int (*LPSelect)(struct IPerlSock*, int, char*, char*, char*, const struct timeval*); typedef int (*LPSend)(struct IPerlSock*, SOCKET, const char*, int, - int); + int); typedef int (*LPSendto)(struct IPerlSock*, SOCKET, const char*, int, int, const struct sockaddr*, int); typedef void (*LPSethostent)(struct IPerlSock*, int); diff --git a/perlio.c b/perlio.c index a88daa5..defe71e 100644 --- a/perlio.c +++ b/perlio.c @@ -15,14 +15,14 @@ # include "config.h" #endif -#define PERLIO_NOT_STDIO 0 +#define PERLIO_NOT_STDIO 0 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) -#define PerlIO FILE +/* #define PerlIO FILE */ #endif /* - * This file provides those parts of PerlIO abstraction + * This file provides those parts of PerlIO abstraction * which are not #defined in iperlsys.h. - * Which these are depends on various Configure #ifdef's + * Which these are depends on various Configure #ifdef's */ #include "EXTERN.h" @@ -31,15 +31,15 @@ #if !defined(PERL_IMPLICIT_SYS) -#ifdef PERLIO_IS_STDIO +#ifdef PERLIO_IS_STDIO void PerlIO_init(void) { - /* Does nothing (yet) except force this file to be included + /* Does nothing (yet) except force this file to be included in perl binary. That allows this file to force inclusion - of other functions that may be required by loadable - extensions e.g. for FileHandle::tmpfile + of other functions that may be required by loadable + extensions e.g. for FileHandle::tmpfile */ } @@ -57,7 +57,7 @@ PerlIO_tmpfile(void) #undef HAS_FSETPOS #undef HAS_FGETPOS -/* This section is just to make sure these functions +/* This section is just to make sure these functions get pulled in from libsfio.a */ @@ -71,14 +71,14 @@ PerlIO_tmpfile(void) void PerlIO_init(void) { - /* Force this file to be included in perl binary. Which allows - * this file to force inclusion of other functions that may be - * required by loadable extensions e.g. for FileHandle::tmpfile + /* Force this file to be included in perl binary. Which allows + * this file to force inclusion of other functions that may be + * required by loadable extensions e.g. for FileHandle::tmpfile */ /* Hack * sfio does its own 'autoflush' on stdout in common cases. - * Flush results in a lot of lseek()s to regular files and + * Flush results in a lot of lseek()s to regular files and * lot of small writes to pipes. */ sfset(sfstdout,SF_SHARE,0); @@ -86,206 +86,519 @@ PerlIO_init(void) #else /* USE_SFIO */ -/* Implement all the PerlIO interface using stdio. - - this should be only file to include +/*======================================================================================*/ + +/* Implement all the PerlIO interface ourselves. */ -#undef PerlIO_stderr +#undef printf +void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2))); + + +void +PerlIO_debug(char *fmt,...) +{ + static int dbg = 0; + if (!dbg) + { + char *s = getenv("PERLIO_DEBUG"); + if (s && *s) + dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666); + else + dbg = -1; + } + if (dbg > 0) + { + dTHX; + va_list ap; + SV *sv = newSVpvn("",0); + char *s; + STRLEN len; + va_start(ap,fmt); + sv_vcatpvf(sv, fmt, &ap); + s = SvPV(sv,len); + write(dbg,s,len); + va_end(ap); + SvREFCNT_dec(sv); + } +} + +#define PERLIO_F_EOF 0x010000 +#define PERLIO_F_ERROR 0x020000 +#define PERLIO_F_LINEBUF 0x040000 +#define PERLIO_F_TEMP 0x080000 +#define PERLIO_F_RDBUF 0x100000 +#define PERLIO_F_WRBUF 0x200000 +#define PERLIO_F_OPEN 0x400000 +#define PERLIO_F_USED 0x800000 + +struct _PerlIO +{ + IV flags; + IV fd; /* Maybe pointer on some OSes */ + int oflags; /* open/fcntl flags */ + STDCHAR *buf; /* Start of buffer */ + STDCHAR *end; /* End of valid part of buffer */ + STDCHAR *ptr; /* Current position in buffer */ + Size_t bufsiz; /* Size of buffer */ + Off_t posn; + int oneword; +}; + +int _perlio_size = 0; +PerlIO **_perlio = NULL; + +void +PerlIO_alloc_buf(PerlIO *f) +{ + if (!f->bufsiz) + f->bufsiz = 2; + New('B',f->buf,f->bufsiz,char); + if (!f->buf) + { + f->buf = (STDCHAR *)&f->oneword; + f->bufsiz = sizeof(f->oneword); + } + f->ptr = f->buf; + f->end = f->ptr; + PerlIO_debug(__FUNCTION__ " f=%p b=%p p=%p e=%p\n", + f,f->buf,f->ptr,f->end); +} + +#undef PerlIO_flush +int +PerlIO_flush(PerlIO *f) +{ + int code = 0; + if (f) + { + PerlIO_debug(__FUNCTION__ " f=%p flags=%08X c=%d buf=%p ptr=%p\n", + f,f->flags,(f->ptr-f->buf),f->buf,f->ptr); + if (f->flags & PERLIO_F_WRBUF) + { + STDCHAR *p = f->buf; + int count; + while (p < f->ptr) + { + count = write(f->fd,p,f->ptr - p); + if (count > 0) + { + p += count; + } + else if (count < 0 && errno != EINTR) + { + code = -1; + break; + } + } + f->posn += (p - f->buf); + } + else if (f->flags & PERLIO_F_RDBUF) + { + f->posn += (f->ptr - f->buf); + if (f->ptr < f->end) + { + f->posn = lseek(f->fd,f->posn,SEEK_SET); + } + } + f->ptr = f->end = f->buf; + f->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + } + else + { + int i; + for (i=_perlio_size; i >= 0; i--) + { + if ((f = _perlio[i])) + { + if (PerlIO_flush(f) != 0) + code = -1; + } + } + } + return code; +} + +int +PerlIO_oflags(const char *mode) +{ + int oflags = -1; + PerlIO_debug(__FUNCTION__ " %s = ",mode); + switch(*mode) + { + case 'r': + oflags = O_RDONLY; + if (*++mode == '+') + { + oflags = O_RDWR; + mode++; + } + break; + + case 'w': + oflags = O_CREAT|O_TRUNC; + if (*++mode == '+') + { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; + + case 'a': + oflags = O_CREAT|O_TRUNC|O_APPEND; + if (*++mode == '+') + { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; + } + if (*mode || oflags == -1) + { + errno = EINVAL; + oflags = -1; + } + PerlIO_debug(" %X '%s'\n",oflags,mode); + return oflags; +} + PerlIO * -PerlIO_stderr(void) +PerlIO_allocate(void) +{ + PerlIO *f; + int i = 0; + while (1) + { + PerlIO **table = _perlio; + while (i < _perlio_size) + { + f = table[i]; + PerlIO_debug(__FUNCTION__ " try %d %p\n",i,f); + if (!f) + { + Newz('F',f,1,PerlIO); + if (!f) + return NULL; + table[i] = f; + } + if (!(f->flags & PERLIO_F_USED)) + { + Zero(f,1,PerlIO); + f->flags = PERLIO_F_USED; + return f; + } + i++; + } + Newz('I',table,_perlio_size+16,PerlIO *); + if (!table) + return NULL; + Copy(_perlio,table,_perlio_size,PerlIO *); + if (_perlio) + Safefree(_perlio); + _perlio = table; + _perlio_size += 16; + } +} + +#undef PerlIO_fdopen +PerlIO * +PerlIO_fdopen(int fd, const char *mode) +{ + PerlIO *f = NULL; + if (fd >= 0) + { + if ((f = PerlIO_allocate())) + { + f->fd = fd; + f->oflags = PerlIO_oflags(mode); + f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED); + } + } + PerlIO_debug(__FUNCTION__ " fd=%d m=%s f=%p\n",fd,mode,f); + return f; +} + +#undef PerlIO_fileno +int +PerlIO_fileno(PerlIO *f) { - return (PerlIO *) stderr; + if (f && (f->flags & PERLIO_F_OPEN)) + { + return f->fd; + } + return -1; +} + +#undef PerlIO_close +int +PerlIO_close(PerlIO *f) +{ + int code = -1; + if (f) + { + PerlIO_flush(f); + while ((code = close(f->fd)) && errno == EINTR); + f->flags &= ~PERLIO_F_OPEN; + f->fd = -1; + if (f->buf && f->buf != (STDCHAR *) &f->oneword) + { + Safefree(f->buf); + } + f->buf = NULL; + f->ptr = f->end = f->buf; + f->flags &= ~(PERLIO_F_USED|PERLIO_F_RDBUF|PERLIO_F_WRBUF); + } + return code; +} + +void +PerlIO_cleanup(void) +{ + int i; + PerlIO_debug(__FUNCTION__ "\n"); + for (i=_perlio_size-1; i >= 0; i--) + { + PerlIO *f = _perlio[i]; + if (f) + { + PerlIO_close(f); + Safefree(f); + } + } + if (_perlio) + Safefree(_perlio); + _perlio = NULL; + _perlio_size = 0; +} + +#undef PerlIO_open +PerlIO * +PerlIO_open(const char *path, const char *mode) +{ + PerlIO *f = NULL; + int oflags = PerlIO_oflags(mode); + if (oflags != -1) + { + int fd = open(path,oflags,0666); + if (fd >= 0) + { + PerlIO_debug(__FUNCTION__ "fd=%d\n",fd); + f = PerlIO_fdopen(fd,mode); + if (!f) + close(fd); + } + } + PerlIO_debug(__FUNCTION__ " path=%s m=%s f=%p\n",path,mode,f); + return f; +} + +#undef PerlIO_reopen +PerlIO * +PerlIO_reopen(const char *path, const char *mode, PerlIO *f) +{ + PerlIO_debug(__FUNCTION__ " n=%s m=%s f=%p\n",path,mode,f); + if (f) + { + int oflags = PerlIO_oflags(mode); + PerlIO_close(f); + if (oflags != -1) + { + int fd = open(path,oflags,0666); + if (fd >= 0) + { + PerlIO_debug(__FUNCTION__ "fd=%d\n",fd); + f->oflags = oflags; + f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED); + } + } + else + { + return NULL; + } + } + return PerlIO_open(path,mode); +} + +void +PerlIO_init(void) +{ + if (!_perlio) + { + atexit(&PerlIO_cleanup); + PerlIO_fdopen(0,"r"); + PerlIO_fdopen(1,"w"); + PerlIO_fdopen(2,"w"); + } + PerlIO_debug(__FUNCTION__ "\n"); } #undef PerlIO_stdin PerlIO * PerlIO_stdin(void) { - return (PerlIO *) stdin; + if (!_perlio) + PerlIO_init(); + return _perlio[0]; } #undef PerlIO_stdout PerlIO * PerlIO_stdout(void) { - return (PerlIO *) stdout; + if (!_perlio) + PerlIO_init(); + return _perlio[1]; +} + +#undef PerlIO_stderr +PerlIO * +PerlIO_stderr(void) +{ + if (!_perlio) + PerlIO_init(); + return _perlio[2]; } #undef PerlIO_fast_gets -int +int PerlIO_fast_gets(PerlIO *f) { -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) return 1; -#else - return 0; -#endif } #undef PerlIO_has_cntptr -int +int PerlIO_has_cntptr(PerlIO *f) { -#if defined(USE_STDIO_PTR) return 1; -#else - return 0; -#endif } #undef PerlIO_canset_cnt -int +int PerlIO_canset_cnt(PerlIO *f) { -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) return 1; -#else - return 0; -#endif } #undef PerlIO_set_cnt void PerlIO_set_cnt(PerlIO *f, int cnt) { - dTHX; - if (cnt < -1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt); -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - FILE_cnt(f) = cnt; -#else - Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system"); -#endif + if (f) + { + dTHX; + if (!f->buf) + PerlIO_alloc_buf(f); + f->ptr = f->end - cnt; + assert(f->ptr >= f->buf); + } } -#undef PerlIO_set_ptrcnt -void -PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) +#undef PerlIO_get_cnt +int +PerlIO_get_cnt(PerlIO *f) { - dTHX; -#ifdef FILE_bufsiz - STDCHAR *e = FILE_base(f) + FILE_bufsiz(f); - int ec = e - ptr; - if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1); - if (cnt != ec && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec); -#endif -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) - FILE_ptr(f) = ptr; -#else - Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system"); -#endif -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - FILE_cnt(f) = cnt; -#else - Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system"); -#endif + if (f) + { + if (!f->buf) + PerlIO_alloc_buf(f); + if (f->flags & PERLIO_F_RDBUF) + return (f->end - f->ptr); + } + return 0; } -#undef PerlIO_get_cnt -int -PerlIO_get_cnt(PerlIO *f) +#undef PerlIO_set_ptrcnt +void +PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) { -#ifdef FILE_cnt - return FILE_cnt(f); -#else - dTHX; - Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system"); - return -1; -#endif + if (f) + { + dTHX; + if (!f->buf) + PerlIO_alloc_buf(f); + f->ptr = ptr; + assert(f->ptr >= f->buf); + if (PerlIO_get_cnt(f) != cnt) + { + dTHX; + assert(PerlIO_get_cnt(f) != cnt); + } + } } #undef PerlIO_get_bufsiz -int +int PerlIO_get_bufsiz(PerlIO *f) { -#ifdef FILE_bufsiz - return FILE_bufsiz(f); -#else - dTHX; - Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system"); + if (f) + { + if (!f->buf) + PerlIO_alloc_buf(f); + return f->bufsiz; + } return -1; -#endif } #undef PerlIO_get_ptr STDCHAR * PerlIO_get_ptr(PerlIO *f) { -#ifdef FILE_ptr - return FILE_ptr(f); -#else - dTHX; - Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system"); + if (f) + { + if (!f->buf) + PerlIO_alloc_buf(f); + return f->ptr; + } return NULL; -#endif } #undef PerlIO_get_base STDCHAR * PerlIO_get_base(PerlIO *f) { -#ifdef FILE_base - return FILE_base(f); -#else - dTHX; - Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system"); + if (f) + { + if (!f->buf) + PerlIO_alloc_buf(f); + return f->buf; + } return NULL; -#endif } -#undef PerlIO_has_base -int +#undef PerlIO_has_base +int PerlIO_has_base(PerlIO *f) { -#ifdef FILE_base - return 1; -#else - return 0; -#endif + if (f) + { + if (!f->buf) + PerlIO_alloc_buf(f); + return f->buf != NULL; + } } #undef PerlIO_puts int PerlIO_puts(PerlIO *f, const char *s) { - return fputs(s,f); -} - -#undef PerlIO_open -PerlIO * -PerlIO_open(const char *path, const char *mode) -{ - return fopen(path,mode); -} - -#undef PerlIO_fdopen -PerlIO * -PerlIO_fdopen(int fd, const char *mode) -{ - return fdopen(fd,mode); -} - -#undef PerlIO_reopen -PerlIO * -PerlIO_reopen(const char *name, const char *mode, PerlIO *f) -{ - return freopen(name,mode,f); -} - -#undef PerlIO_close -int -PerlIO_close(PerlIO *f) -{ - return fclose(f); + STRLEN len = strlen(s); + return PerlIO_write(f,s,len); } #undef PerlIO_eof -int +int PerlIO_eof(PerlIO *f) { - return feof(f); + if (f) + { + return (f->flags & PERLIO_F_EOF) != 0; + } + return 1; } #undef PerlIO_getname @@ -301,134 +614,224 @@ PerlIO_getname(PerlIO *f, char *buf) #endif } +#undef PerlIO_ungetc +int +PerlIO_ungetc(PerlIO *f, int ch) +{ + PerlIO_debug(__FUNCTION__ " f=%p c=%c\n",f,ch); + if (f->buf && (f->flags & PERLIO_F_RDBUF) && f->ptr > f->buf) + { + *--(f->ptr) = ch; + return ch; + } + return -1; +} + +#undef PerlIO_read +SSize_t +PerlIO_read(PerlIO *f, void *vbuf, Size_t count) +{ + STDCHAR *buf = (STDCHAR *) vbuf; + if (f) + { + Size_t got = 0; + if (!f->ptr) + PerlIO_alloc_buf(f); + + while (count > 0) + { + SSize_t avail = (f->end - f->ptr); + if ((SSize_t) count < avail) + avail = count; + if (avail > 0) + { + Copy(f->ptr,buf,avail,char); + got += avail; + f->ptr += avail; + count -= avail; + buf += avail; + } + if (count && (f->ptr >= f->end)) + { + f->ptr = f->end = f->buf; + avail = read(f->fd,f->ptr,f->bufsiz); + if (avail <= 0) + { + if (avail == 0) + f->flags |= PERLIO_F_EOF; + else if (errno == EINTR) + continue; + else + f->flags |= PERLIO_F_ERROR; + break; + } + f->end = f->buf+avail; + f->flags |= PERLIO_F_RDBUF; + } + } + return got; + } + return 0; +} + #undef PerlIO_getc -int +int PerlIO_getc(PerlIO *f) { - return fgetc(f); + STDCHAR buf; + int count = PerlIO_read(f,&buf,1); + if (count == 1) + return buf; + return -1; } #undef PerlIO_error -int +int PerlIO_error(PerlIO *f) { - return ferror(f); + if (f) + { + return f->flags & PERLIO_F_ERROR; + } + return 1; } #undef PerlIO_clearerr void PerlIO_clearerr(PerlIO *f) { - clearerr(f); -} - -#undef PerlIO_flush -int -PerlIO_flush(PerlIO *f) -{ - return Fflush(f); -} - -#undef PerlIO_fileno -int -PerlIO_fileno(PerlIO *f) -{ - return fileno(f); + if (f) + { + f->flags &= ~PERLIO_F_ERROR; + } } #undef PerlIO_setlinebuf void PerlIO_setlinebuf(PerlIO *f) { -#ifdef HAS_SETLINEBUF - setlinebuf(f); -#else -# ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */ - setvbuf(f, Nullch, _IOLBF, BUFSIZ); -# else - setvbuf(f, Nullch, _IOLBF, 0); -# endif -#endif -} - -#undef PerlIO_putc -int -PerlIO_putc(PerlIO *f, int ch) -{ - return putc(ch,f); -} - -#undef PerlIO_ungetc -int -PerlIO_ungetc(PerlIO *f, int ch) -{ - return ungetc(ch,f); -} - -#undef PerlIO_read -SSize_t -PerlIO_read(PerlIO *f, void *buf, Size_t count) -{ - return fread(buf,1,count,f); + if (f) + { + f->flags &= ~PERLIO_F_LINEBUF; + } } #undef PerlIO_write SSize_t -PerlIO_write(PerlIO *f, const void *buf, Size_t count) +PerlIO_write(PerlIO *f, const void *vbuf, Size_t count) { - return fwrite1(buf,1,count,f); + const STDCHAR *buf = (const STDCHAR *) vbuf; + Size_t written = 0; + PerlIO_debug(__FUNCTION__ " f=%p c=%d\n",f,count); + if (f) + { + if (!f->buf) + PerlIO_alloc_buf(f); + while (count > 0) + { + Size_t avail = f->bufsiz - (f->ptr - f->buf); + if (count < avail) + avail = count; + f->flags |= PERLIO_F_WRBUF; + if (f->flags & PERLIO_F_LINEBUF) + { + while (avail > 0) + { + int ch = *buf++; + *(f->ptr)++ = ch; + count--; + avail--; + written++; + if (ch == '\n') + PerlIO_flush(f); + } + } + else + { + if (avail) + { + Copy(buf,f->ptr,avail,char); + count -= avail; + buf += avail; + written += avail; + f->ptr += avail; + } + } + if (f->ptr >= (f->buf + f->bufsiz)) + PerlIO_flush(f); + } + } + return written; } -#undef PerlIO_vprintf -int -PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) +#undef PerlIO_putc +int +PerlIO_putc(PerlIO *f, int ch) { - return vfprintf(f,fmt,ap); + STDCHAR buf = ch; + PerlIO_write(f,&ch,1); } #undef PerlIO_tell Off_t PerlIO_tell(PerlIO *f) { -#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64) - return ftello(f); -#else - return ftell(f); -#endif + Off_t posn = f->posn + (f->ptr - f->buf); + return posn; } #undef PerlIO_seek int PerlIO_seek(PerlIO *f, Off_t offset, int whence) { -#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64) - return fseeko(f,offset,whence); -#else - return fseek(f,offset,whence); -#endif + int code = PerlIO_flush(f); + if (code == 0) + { + f->flags &= ~PERLIO_F_EOF; + f->posn = lseek(f->fd,offset,whence); + if (f->posn == (Off_t) -1) + { + f->posn = 0; + code = -1; + } + } + return code; } #undef PerlIO_rewind void PerlIO_rewind(PerlIO *f) { - rewind(f); + PerlIO_seek(f,(Off_t)0,SEEK_SET); +} + +#undef PerlIO_vprintf +int +PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) +{ + dTHX; + SV *sv = newSV(strlen(fmt)); + char *s; + STRLEN len; + sv_vcatpvf(sv, fmt, &ap); + s = SvPV(sv,len); + return (PerlIO_write(f,s,len) == len) ? 1 : 0; } #undef PerlIO_printf -int +int PerlIO_printf(PerlIO *f,const char *fmt,...) { va_list ap; int result; va_start(ap,fmt); - result = vfprintf(f,fmt,ap); + result = PerlIO_vprintf(f,fmt,ap); va_end(ap); return result; } #undef PerlIO_stdoutf -int +int PerlIO_stdoutf(const char *fmt,...) { va_list ap; @@ -443,28 +846,44 @@ PerlIO_stdoutf(const char *fmt,...) PerlIO * PerlIO_tmpfile(void) { - return tmpfile(); + dTHX; + SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0); + int fd = mkstemp(SvPVX(sv)); + PerlIO *f = NULL; + if (fd >= 0) + { + PerlIO *f = PerlIO_fdopen(fd,"w+"); + if (f) + { + f->flags |= PERLIO_F_TEMP; + } + unlink(SvPVX(sv)); + SvREFCNT_dec(sv); + } + return f; } #undef PerlIO_importFILE PerlIO * PerlIO_importFILE(FILE *f, int fl) { - return f; + int fd = fileno(f); + return PerlIO_fdopen(fd,"r+"); } #undef PerlIO_exportFILE FILE * PerlIO_exportFILE(PerlIO *f, int fl) { - return f; + PerlIO_flush(f); + return fdopen(PerlIO_fileno(f),"r+"); } #undef PerlIO_findFILE FILE * PerlIO_findFILE(PerlIO *f) { - return f; + return PerlIO_exportFILE(f,0); } #undef PerlIO_releaseFILE @@ -473,15 +892,10 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) { } -void -PerlIO_init(void) -{ - /* Does nothing (yet) except force this file to be included - in perl binary. That allows this file to force inclusion - of other functions that may be required by loadable - extensions e.g. for FileHandle::tmpfile - */ -} +#undef HAS_FSETPOS +#undef HAS_FGETPOS + +/*======================================================================================*/ #endif /* USE_SFIO */ #endif /* PERLIO_IS_STDIO */ @@ -491,7 +905,7 @@ PerlIO_init(void) int PerlIO_setpos(PerlIO *f, const Fpos_t *pos) { - return PerlIO_seek(f,*pos,0); + return PerlIO_seek(f,*pos,0); } #else #ifndef PERLIO_IS_STDIO @@ -550,7 +964,7 @@ vfprintf(FILE *fd, char *pat, char *args) #endif #ifndef PerlIO_vsprintf -int +int PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) { int val = vsprintf(s, fmt, ap); @@ -568,7 +982,7 @@ PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) #endif #ifndef PerlIO_sprintf -int +int PerlIO_sprintf(char *s, int n, const char *fmt,...) { va_list ap;