perlio.c

/*    perlio.c
 *
 *    Copyright (c) 1996-2001, Nick Ing-Simmons
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */


#define VOIDUSED 1
#include "config.h"

#define PERLIO_NOT_STDIO 0 
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
#define PerlIO FILE
#endif
/*
 * This file provides those parts of PerlIO abstraction 
 * which are not #defined in iperlsys.h.
 * Which these are depends on various Configure #ifdef's 
 */

#include "EXTERN.h"
#define PERL_IN_PERLIO_C
#include "perl.h"

#if !defined(PERL_IMPLICIT_SYS)

#ifdef PERLIO_IS_STDIO 

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 PerlIO_tmpfile
PerlIO *
PerlIO_tmpfile(void)
{
 return tmpfile();
}

#else /* PERLIO_IS_STDIO */

#ifdef USE_SFIO

#undef HAS_FSETPOS
#undef HAS_FGETPOS

/* This section is just to make sure these functions 
   get pulled in from libsfio.a
*/

#undef PerlIO_tmpfile
PerlIO *
PerlIO_tmpfile(void)
{
 return sftmp(0);
}

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  
  */

 /* Hack
  * sfio does its own 'autoflush' on stdout in common cases.
  * Flush results in a lot of lseek()s to regular files and 
  * lot of small writes to pipes.
  */
 sfset(sfstdout,SF_SHARE,0);
}

#else /* USE_SFIO */

/* Implement all the PerlIO interface using stdio. 
   - this should be only file to include <stdio.h>
*/

#undef PerlIO_stderr
PerlIO *
PerlIO_stderr(void)
{
 return (PerlIO *) stderr;
}

#undef PerlIO_stdin
PerlIO *
PerlIO_stdin(void)
{
 return (PerlIO *) stdin;
}

#undef PerlIO_stdout
PerlIO *
PerlIO_stdout(void)
{
 return (PerlIO *) stdout;
}

#undef PerlIO_fast_gets
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 
PerlIO_has_cntptr(PerlIO *f)
{
#if defined(USE_STDIO_PTR)
 return 1;
#else
 return 0;
#endif
}

#undef PerlIO_canset_cnt
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
}

#undef PerlIO_set_ptrcnt
void
PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
{
 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) && defined (STDIO_PTR_LVAL_NOCHANGE_CNT)
  FILE_cnt(f) = cnt;
#else
#if defined(STDIO_PTR_LVAL_SETS_CNT)
  assert (FILE_cnt(f) == cnt);
#else
  Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system when setting 'ptr'");
#endif
#endif
}

#undef PerlIO_get_cnt
int 
PerlIO_get_cnt(PerlIO *f)
{
#ifdef FILE_cnt
 return FILE_cnt(f);
#else
 dTHX;
 Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system");
 return -1;
#endif
}

#undef PerlIO_get_bufsiz
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");
 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");
 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");
 return NULL;
#endif
}

#undef PerlIO_has_base 
int 
PerlIO_has_base(PerlIO *f)
{
#ifdef FILE_base
 return 1;
#else
 return 0;
#endif
}

#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);
}

#undef PerlIO_eof
int      
PerlIO_eof(PerlIO *f)
{
 return feof(f);
}

#undef PerlIO_getname
char *
PerlIO_getname(PerlIO *f, char *buf)
{
#ifdef VMS
 return fgetname(f,buf);
#else
 dTHX;
 Perl_croak(aTHX_ "Don't know how to get file name");
 return NULL;
#endif
}

#undef PerlIO_getc
int      
PerlIO_getc(PerlIO *f)
{
 return fgetc(f);
}

#undef PerlIO_error
int      
PerlIO_error(PerlIO *f)
{
 return ferror(f);
}

#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);
}

#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);
}

#undef PerlIO_write
SSize_t
PerlIO_write(PerlIO *f, const void *buf, Size_t count)
{
 return fwrite1(buf,1,count,f);
}

#undef PerlIO_vprintf
int      
PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
{
 return vfprintf(f,fmt,ap);
}

#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
}

#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
}

#undef PerlIO_rewind
void
PerlIO_rewind(PerlIO *f)
{
 rewind(f);
}

#undef PerlIO_printf
int      
PerlIO_printf(PerlIO *f,const char *fmt,...)
{
 va_list ap;
 int result;
 va_start(ap,fmt);
 result = vfprintf(f,fmt,ap);
 va_end(ap);
 return result;
}

#undef PerlIO_stdoutf
int      
PerlIO_stdoutf(const char *fmt,...)
{
 va_list ap;
 int result;
 va_start(ap,fmt);
 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
 va_end(ap);
 return result;
}

#undef PerlIO_tmpfile
PerlIO *
PerlIO_tmpfile(void)
{
 return tmpfile();
}

#undef PerlIO_importFILE
PerlIO *
PerlIO_importFILE(FILE *f, int fl)
{
 return f;
}

#undef PerlIO_exportFILE
FILE *
PerlIO_exportFILE(PerlIO *f, int fl)
{
 return f;
}

#undef PerlIO_findFILE
FILE *
PerlIO_findFILE(PerlIO *f)
{
 return f;
}

#undef PerlIO_releaseFILE
void
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  
 */
}

#endif /* USE_SFIO */
#endif /* PERLIO_IS_STDIO */

#ifndef HAS_FSETPOS
#undef PerlIO_setpos
int
#ifdef USE_SFIO
PerlIO_setpos(PerlIO *f, const Off_t *pos)
#else
PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
#endif
{
 return PerlIO_seek(f,*pos,0); 
}
#else
#ifndef PERLIO_IS_STDIO
#undef PerlIO_setpos
int
PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
{
#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
 return fsetpos64(f, pos);
#else
 return fsetpos(f, pos);
#endif
}
#endif
#endif

#ifndef HAS_FGETPOS
#undef PerlIO_getpos
int
#ifdef USE_SFIO
PerlIO_getpos(PerlIO *f, Off_t *pos)
{
 *pos = PerlIO_seek(f,0,0);
 return 0;
}
#else
PerlIO_getpos(PerlIO *f, Fpos_t *pos)
{
 *pos = PerlIO_tell(f);
 return 0;
}
#endif
#else
#ifndef PERLIO_IS_STDIO
#undef PerlIO_getpos
int
PerlIO_getpos(PerlIO *f, Fpos_t *pos)
{
#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
 return fgetpos64(f, pos);
#else
 return fgetpos(f, pos);
#endif
}
#endif
#endif

#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)

int
vprintf(char *pat, char *args)
{
    _doprnt(pat, args, stdout);
    return 0;		/* wrong, but perl doesn't use the return value */
}

int
vfprintf(FILE *fd, char *pat, char *args)
{
    _doprnt(pat, args, fd);
    return 0;		/* wrong, but perl doesn't use the return value */
}

#endif

#ifndef PerlIO_vsprintf
int 
PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
{
 int val = vsprintf(s, fmt, ap);
 if (n >= 0)
  {
   if (strlen(s) >= (STRLEN)n)
    {
     dTHX;
     PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
     my_exit(1);
    }
  }
 return val;
}
#endif

#ifndef PerlIO_sprintf
int      
PerlIO_sprintf(char *s, int n, const char *fmt,...)
{
 va_list ap;
 int result;
 va_start(ap,fmt);
 result = PerlIO_vsprintf(s, n, fmt, ap);
 va_end(ap);
 return result;
}
#endif

#endif /* !PERL_IMPLICIT_SYS */