[p5sagit/p5-mst-13.2.git] / perlio.c

/*    perlio.c
 *
 *    Copyright (c) 1996-2000, 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
#ifdef PERL_MICRO
#   include "uconfig.h"
#else
#   include "config.h"
#endif

#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 ourselves.
*/

#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_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)
{
 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)
{
 if (!_perlio)
  PerlIO_init();
 return _perlio[0];
}

#undef PerlIO_stdout
PerlIO *
PerlIO_stdout(void)
{
 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
PerlIO_fast_gets(PerlIO *f)
{
 return 1;
}

#undef PerlIO_has_cntptr
int
PerlIO_has_cntptr(PerlIO *f)
{
 return 1;
}

#undef PerlIO_canset_cnt
int
PerlIO_canset_cnt(PerlIO *f)
{
 return 1;
}

#undef PerlIO_set_cnt
void
PerlIO_set_cnt(PerlIO *f, int cnt)
{
 if (f)
  {
   dTHX;
   if (!f->buf)
    PerlIO_alloc_buf(f);
   f->ptr = f->end - cnt;
   assert(f->ptr >= f->buf);
  }
}

#undef PerlIO_get_cnt
int
PerlIO_get_cnt(PerlIO *f)
{
 if (f)
  {
   if (!f->buf)
    PerlIO_alloc_buf(f);
   if (f->flags & PERLIO_F_RDBUF)
    return (f->end - f->ptr);
  }
 return 0;
}

#undef PerlIO_set_ptrcnt
void
PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
{
 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
PerlIO_get_bufsiz(PerlIO *f)
{
 if (f)
  {
   if (!f->buf)
    PerlIO_alloc_buf(f);
   return f->bufsiz;
  }
 return -1;
}

#undef PerlIO_get_ptr
STDCHAR *
PerlIO_get_ptr(PerlIO *f)
{
 if (f)
  {
   if (!f->buf)
    PerlIO_alloc_buf(f);
   return f->ptr;
  }
 return NULL;
}

#undef PerlIO_get_base
STDCHAR *
PerlIO_get_base(PerlIO *f)
{
 if (f)
  {
   if (!f->buf)
    PerlIO_alloc_buf(f);
   return f->buf;
  }
 return NULL;
}

#undef PerlIO_has_base
int
PerlIO_has_base(PerlIO *f)
{
 if (f)
  {
   if (!f->buf)
    PerlIO_alloc_buf(f);
   return f->buf != NULL;
  }
}

#undef PerlIO_puts
int
PerlIO_puts(PerlIO *f, const char *s)
{
 STRLEN len = strlen(s);
 return PerlIO_write(f,s,len);
}

#undef PerlIO_eof
int
PerlIO_eof(PerlIO *f)
{
 if (f)
  {
   return (f->flags & PERLIO_F_EOF) != 0;
  }
 return 1;
}

#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_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
PerlIO_getc(PerlIO *f)
{
 STDCHAR buf;
 int count = PerlIO_read(f,&buf,1);
 if (count == 1)
  return buf;
 return -1;
}

#undef PerlIO_error
int
PerlIO_error(PerlIO *f)
{
 if (f)
  {
   return f->flags & PERLIO_F_ERROR;
  }
 return 1;
}

#undef PerlIO_clearerr
void
PerlIO_clearerr(PerlIO *f)
{
 if (f)
  {
   f->flags &= ~PERLIO_F_ERROR;
  }
}

#undef PerlIO_setlinebuf
void
PerlIO_setlinebuf(PerlIO *f)
{
 if (f)
  {
   f->flags &= ~PERLIO_F_LINEBUF;
  }
}

#undef PerlIO_write
SSize_t
PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
{
 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_putc
int
PerlIO_putc(PerlIO *f, int ch)
{
 STDCHAR buf = ch;
 PerlIO_write(f,&ch,1);
}

#undef PerlIO_tell
Off_t
PerlIO_tell(PerlIO *f)
{
 Off_t posn = f->posn + (f->ptr - f->buf);
 return posn;
}

#undef PerlIO_seek
int
PerlIO_seek(PerlIO *f, Off_t offset, int whence)
{
 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)
{
 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
PerlIO_printf(PerlIO *f,const char *fmt,...)
{
 va_list ap;
 int result;
 va_start(ap,fmt);
 result = PerlIO_vprintf(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)
{
 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)
{
 int fd = fileno(f);
 return PerlIO_fdopen(fd,"r+");
}

#undef PerlIO_exportFILE
FILE *
PerlIO_exportFILE(PerlIO *f, int fl)
{
 PerlIO_flush(f);
 return fdopen(PerlIO_fileno(f),"r+");
}

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

#undef PerlIO_releaseFILE
void
PerlIO_releaseFILE(PerlIO *p, FILE *f)
{
}

#undef HAS_FSETPOS
#undef HAS_FGETPOS

/*======================================================================================*/

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

#ifndef HAS_FSETPOS
#undef PerlIO_setpos
int
PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
{
 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
PerlIO_getpos(PerlIO *f, Fpos_t *pos)
{
 *pos = PerlIO_tell(f);
 return 0;
}
#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 */
Commit	Line	Data
760ac839	1	/* perlio.c
760ac839	2	*
1761cee5	3	* Copyright (c) 1996-2000, Nick Ing-Simmons
760ac839	4	*
	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.
	7	*
	8	*/
	9
c5be433b	10
760ac839	11	#define VOIDUSED 1
12ae5dfc	12	#ifdef PERL_MICRO
	13	# include "uconfig.h"
	14	#else
	15	# include "config.h"
	16	#endif
760ac839	17
6f9d8c32	18	#define PERLIO_NOT_STDIO 0
760ac839	19	#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
6f9d8c32	20	/* #define PerlIO FILE */
760ac839	21	#endif
760ac839	22	/*
6f9d8c32	23	* This file provides those parts of PerlIO abstraction
0f4eea8f	24	* which are not #defined in iperlsys.h.
6f9d8c32	25	* Which these are depends on various Configure #ifdef's
760ac839	26	*/
	27
	28	#include "EXTERN.h"
864dbfa3	29	#define PERL_IN_PERLIO_C
760ac839	30	#include "perl.h"
760ac839	31
32e30700	32	#if !defined(PERL_IMPLICIT_SYS)
32e30700	33
6f9d8c32	34	#ifdef PERLIO_IS_STDIO
760ac839	35
760ac839	36	void
8ac85365	37	PerlIO_init(void)
760ac839	38	{
6f9d8c32	39	/* Does nothing (yet) except force this file to be included
760ac839	40	in perl binary. That allows this file to force inclusion
6f9d8c32	41	of other functions that may be required by loadable
6f9d8c32	42	extensions e.g. for FileHandle::tmpfile
760ac839	43	*/
	44	}
	45
33dcbb9a	46	#undef PerlIO_tmpfile
33dcbb9a	47	PerlIO *
8ac85365	48	PerlIO_tmpfile(void)
33dcbb9a	49	{
	50	return tmpfile();
	51	}
	52
760ac839	53	#else /* PERLIO_IS_STDIO */
	54
	55	#ifdef USE_SFIO
	56
	57	#undef HAS_FSETPOS
	58	#undef HAS_FGETPOS
	59
6f9d8c32	60	/* This section is just to make sure these functions
760ac839	61	get pulled in from libsfio.a
	62	*/
	63
	64	#undef PerlIO_tmpfile
	65	PerlIO *
c78749f2	66	PerlIO_tmpfile(void)
760ac839	67	{
	68	return sftmp(0);
	69	}
	70
	71	void
c78749f2	72	PerlIO_init(void)
760ac839	73	{
6f9d8c32	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
760ac839	77	*/
	78
	79	/* Hack
	80	* sfio does its own 'autoflush' on stdout in common cases.
6f9d8c32	81	* Flush results in a lot of lseek()s to regular files and
760ac839	82	* lot of small writes to pipes.
	83	*/
	84	sfset(sfstdout,SF_SHARE,0);
	85	}
	86
17c3b450	87	#else /* USE_SFIO */
760ac839	88
6f9d8c32	89	/======================================================================================/
	90
	91	/* Implement all the PerlIO interface ourselves.
760ac839	92	*/
760ac839	93
6f9d8c32	94	#undef printf
	95	void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
	96
	97
	98	void
	99	PerlIO_debug(char *fmt,...)
	100	{
	101	static int dbg = 0;
	102	if (!dbg)
	103	{
	104	char *s = getenv("PERLIO_DEBUG");
	105	if (s && *s)
	106	dbg = open(s,O_WRONLY\|O_CREAT\|O_APPEND,0666);
	107	else
	108	dbg = -1;
	109	}
	110	if (dbg > 0)
	111	{
	112	dTHX;
	113	va_list ap;
	114	SV *sv = newSVpvn("",0);
	115	char *s;
	116	STRLEN len;
	117	va_start(ap,fmt);
	118	sv_vcatpvf(sv, fmt, &ap);
	119	s = SvPV(sv,len);
	120	write(dbg,s,len);
	121	va_end(ap);
	122	SvREFCNT_dec(sv);
	123	}
	124	}
	125
	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
	134
	135	struct _PerlIO
	136	{
	137	IV flags;
	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;
	145	int oneword;
	146	};
	147
	148	int _perlio_size = 0;
	149	PerlIO **_perlio = NULL;
	150
	151	void
	152	PerlIO_alloc_buf(PerlIO *f)
	153	{
	154	if (!f->bufsiz)
	155	f->bufsiz = 2;
	156	New('B',f->buf,f->bufsiz,char);
	157	if (!f->buf)
158	{
159	f->buf = (STDCHAR *)&f->oneword;
160	f->bufsiz = sizeof(f->oneword);
161	}
162	f->ptr = f->buf;
163	f->end = f->ptr;
164	PerlIO_debug(__FUNCTION__ " f=%p b=%p p=%p e=%p\n",
165	f,f->buf,f->ptr,f->end);
166	}
167
168	#undef PerlIO_flush
169	int
170	PerlIO_flush(PerlIO *f)
171	{
172	int code = 0;
173	if (f)
174	{
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)
178	{
179	STDCHAR *p = f->buf;
180	int count;
181	while (p < f->ptr)
182	{
183	count = write(f->fd,p,f->ptr - p);
184	if (count > 0)
185	{
186	p += count;
187	}
188	else if (count < 0 && errno != EINTR)
189	{
190	code = -1;
191	break;
192	}
193	}
194	f->posn += (p - f->buf);
195	}
196	else if (f->flags & PERLIO_F_RDBUF)
197	{
198	f->posn += (f->ptr - f->buf);
199	if (f->ptr < f->end)
200	{
201	f->posn = lseek(f->fd,f->posn,SEEK_SET);
202	}
203	}
204	f->ptr = f->end = f->buf;
205	f->flags &= ~(PERLIO_F_RDBUF\|PERLIO_F_WRBUF);
206	}
207	else
208	{
209	int i;
210	for (i=_perlio_size; i >= 0; i--)
211	{
212	if ((f = _perlio[i]))
213	{
214	if (PerlIO_flush(f) != 0)
215	code = -1;
216	}
217	}
218	}
219	return code;
220	}
221
222	int
223	PerlIO_oflags(const char *mode)
224	{
225	int oflags = -1;
226	PerlIO_debug(__FUNCTION__ " %s = ",mode);
227	switch(*mode)
228	{
229	case 'r':
230	oflags = O_RDONLY;
231	if (*++mode == '+')
232	{
233	oflags = O_RDWR;
234	mode++;
235	}
236	break;
237
238	case 'w':
239	oflags = O_CREAT\|O_TRUNC;
240	if (*++mode == '+')
241	{
242	oflags \|= O_RDWR;
243	mode++;
244	}
245	else
246	oflags \|= O_WRONLY;
247	break;
248
249	case 'a':
250	oflags = O_CREAT\|O_TRUNC\|O_APPEND;
251	if (*++mode == '+')
252	{
253	oflags \|= O_RDWR;
254	mode++;
255	}
256	else
257	oflags \|= O_WRONLY;
258	break;
259	}
260	if (*mode \|\| oflags == -1)
261	{
262	errno = EINVAL;
263	oflags = -1;
264	}
265	PerlIO_debug(" %X '%s'\n",oflags,mode);
266	return oflags;
267	}
268
760ac839	269	PerlIO *
6f9d8c32	270	PerlIO_allocate(void)
	271	{
	272	PerlIO *f;
	273	int i = 0;
	274	while (1)
	275	{
	276	PerlIO **table = _perlio;
	277	while (i < _perlio_size)
	278	{
	279	f = table[i];
	280	PerlIO_debug(__FUNCTION__ " try %d %p\n",i,f);
	281	if (!f)
	282	{
	283	Newz('F',f,1,PerlIO);
	284	if (!f)
	285	return NULL;
	286	table[i] = f;
	287	}
	288	if (!(f->flags & PERLIO_F_USED))
	289	{
	290	Zero(f,1,PerlIO);
	291	f->flags = PERLIO_F_USED;
	292	return f;
	293	}
	294	i++;
	295	}
	296	Newz('I',table,_perlio_size+16,PerlIO *);
	297	if (!table)
	298	return NULL;
	299	Copy(_perlio,table,_perlio_size,PerlIO *);
	300	if (_perlio)
	301	Safefree(_perlio);
	302	_perlio = table;
	303	_perlio_size += 16;
	304	}
	305	}
	306
	307	#undef PerlIO_fdopen
	308	PerlIO *
	309	PerlIO_fdopen(int fd, const char *mode)
	310	{
	311	PerlIO *f = NULL;
	312	if (fd >= 0)
	313	{
	314	if ((f = PerlIO_allocate()))
	315	{
	316	f->fd = fd;
	317	f->oflags = PerlIO_oflags(mode);
	318	f->flags \|= (PERLIO_F_OPEN\|PERLIO_F_USED);
	319	}
	320	}
	321	PerlIO_debug(__FUNCTION__ " fd=%d m=%s f=%p\n",fd,mode,f);
	322	return f;
	323	}
	324
	325	#undef PerlIO_fileno
	326	int
	327	PerlIO_fileno(PerlIO *f)
760ac839	328	{
6f9d8c32	329	if (f && (f->flags & PERLIO_F_OPEN))
	330	{
	331	return f->fd;
	332	}
	333	return -1;
	334	}
	335
	336	#undef PerlIO_close
	337	int
	338	PerlIO_close(PerlIO *f)
	339	{
	340	int code = -1;
	341	if (f)
	342	{
	343	PerlIO_flush(f);
	344	while ((code = close(f->fd)) && errno == EINTR);
	345	f->flags &= ~PERLIO_F_OPEN;
	346	f->fd = -1;
	347	if (f->buf && f->buf != (STDCHAR *) &f->oneword)
	348	{
	349	Safefree(f->buf);
	350	}
	351	f->buf = NULL;
	352	f->ptr = f->end = f->buf;
	353	f->flags &= ~(PERLIO_F_USED\|PERLIO_F_RDBUF\|PERLIO_F_WRBUF);
	354	}
	355	return code;
	356	}
	357
	358	void
	359	PerlIO_cleanup(void)
	360	{
	361	int i;
	362	PerlIO_debug(__FUNCTION__ "\n");
	363	for (i=_perlio_size-1; i >= 0; i--)
	364	{
	365	PerlIO *f = _perlio[i];
	366	if (f)
	367	{
	368	PerlIO_close(f);
	369	Safefree(f);
	370	}
	371	}
	372	if (_perlio)
	373	Safefree(_perlio);
	374	_perlio = NULL;
	375	_perlio_size = 0;
	376	}
	377
	378	#undef PerlIO_open
	379	PerlIO *
	380	PerlIO_open(const char path, const char mode)
	381	{
	382	PerlIO *f = NULL;
	383	int oflags = PerlIO_oflags(mode);
	384	if (oflags != -1)
	385	{
	386	int fd = open(path,oflags,0666);
	387	if (fd >= 0)
	388	{
	389	PerlIO_debug(__FUNCTION__ "fd=%d\n",fd);
	390	f = PerlIO_fdopen(fd,mode);
	391	if (!f)
	392	close(fd);
393	}
394	}
395	PerlIO_debug(__FUNCTION__ " path=%s m=%s f=%p\n",path,mode,f);
396	return f;
397	}
398
399	#undef PerlIO_reopen
400	PerlIO *
401	PerlIO_reopen(const char path, const char mode, PerlIO *f)
402	{
403	PerlIO_debug(__FUNCTION__ " n=%s m=%s f=%p\n",path,mode,f);
404	if (f)
405	{
406	int oflags = PerlIO_oflags(mode);
407	PerlIO_close(f);
408	if (oflags != -1)
409	{
410	int fd = open(path,oflags,0666);
411	if (fd >= 0)
412	{
413	PerlIO_debug(__FUNCTION__ "fd=%d\n",fd);
414	f->oflags = oflags;
415	f->flags \|= (PERLIO_F_OPEN\|PERLIO_F_USED);
416	}
417	}
418	else
419	{
420	return NULL;
421	}
422	}
423	return PerlIO_open(path,mode);
424	}
425
426	void
427	PerlIO_init(void)
428	{
429	if (!_perlio)
430	{
431	atexit(&PerlIO_cleanup);
432	PerlIO_fdopen(0,"r");
433	PerlIO_fdopen(1,"w");
434	PerlIO_fdopen(2,"w");
435	}
436	PerlIO_debug(__FUNCTION__ "\n");
760ac839	437	}
	438
	439	#undef PerlIO_stdin
	440	PerlIO *
c78749f2	441	PerlIO_stdin(void)
760ac839	442	{
6f9d8c32	443	if (!_perlio)
	444	PerlIO_init();
	445	return _perlio[0];
760ac839	446	}
	447
	448	#undef PerlIO_stdout
	449	PerlIO *
c78749f2	450	PerlIO_stdout(void)
760ac839	451	{
6f9d8c32	452	if (!_perlio)
	453	PerlIO_init();
	454	return _perlio[1];
	455	}
	456
	457	#undef PerlIO_stderr
	458	PerlIO *
	459	PerlIO_stderr(void)
	460	{
	461	if (!_perlio)
	462	PerlIO_init();
	463	return _perlio[2];
760ac839	464	}
760ac839	465
760ac839	466	#undef PerlIO_fast_gets
6f9d8c32	467	int
c78749f2	468	PerlIO_fast_gets(PerlIO *f)
760ac839	469	{
760ac839	470	return 1;
760ac839	471	}
	472
	473	#undef PerlIO_has_cntptr
6f9d8c32	474	int
c78749f2	475	PerlIO_has_cntptr(PerlIO *f)
760ac839	476	{
760ac839	477	return 1;
760ac839	478	}
	479
	480	#undef PerlIO_canset_cnt
6f9d8c32	481	int
c78749f2	482	PerlIO_canset_cnt(PerlIO *f)
760ac839	483	{
760ac839	484	return 1;
760ac839	485	}
	486
	487	#undef PerlIO_set_cnt
	488	void
a20bf0c3	489	PerlIO_set_cnt(PerlIO *f, int cnt)
760ac839	490	{
6f9d8c32	491	if (f)
	492	{
	493	dTHX;
	494	if (!f->buf)
	495	PerlIO_alloc_buf(f);
	496	f->ptr = f->end - cnt;
	497	assert(f->ptr >= f->buf);
	498	}
760ac839	499	}
760ac839	500
6f9d8c32	501	#undef PerlIO_get_cnt
	502	int
	503	PerlIO_get_cnt(PerlIO *f)
760ac839	504	{
6f9d8c32	505	if (f)
	506	{
	507	if (!f->buf)
	508	PerlIO_alloc_buf(f);
	509	if (f->flags & PERLIO_F_RDBUF)
	510	return (f->end - f->ptr);
	511	}
	512	return 0;
760ac839	513	}
760ac839	514
6f9d8c32	515	#undef PerlIO_set_ptrcnt
	516	void
	517	PerlIO_set_ptrcnt(PerlIO f, STDCHAR ptr, int cnt)
760ac839	518	{
6f9d8c32	519	if (f)
	520	{
	521	dTHX;
	522	if (!f->buf)
	523	PerlIO_alloc_buf(f);
	524	f->ptr = ptr;
	525	assert(f->ptr >= f->buf);
	526	if (PerlIO_get_cnt(f) != cnt)
	527	{
	528	dTHX;
	529	assert(PerlIO_get_cnt(f) != cnt);
	530	}
	531	}
760ac839	532	}
	533
	534	#undef PerlIO_get_bufsiz
6f9d8c32	535	int
a20bf0c3	536	PerlIO_get_bufsiz(PerlIO *f)
760ac839	537	{
6f9d8c32	538	if (f)
	539	{
	540	if (!f->buf)
	541	PerlIO_alloc_buf(f);
	542	return f->bufsiz;
	543	}
760ac839	544	return -1;
760ac839	545	}
	546
	547	#undef PerlIO_get_ptr
888911fc	548	STDCHAR *
a20bf0c3	549	PerlIO_get_ptr(PerlIO *f)
760ac839	550	{
6f9d8c32	551	if (f)
	552	{
	553	if (!f->buf)
	554	PerlIO_alloc_buf(f);
	555	return f->ptr;
	556	}
760ac839	557	return NULL;
760ac839	558	}
	559
	560	#undef PerlIO_get_base
888911fc	561	STDCHAR *
a20bf0c3	562	PerlIO_get_base(PerlIO *f)
760ac839	563	{
6f9d8c32	564	if (f)
	565	{
	566	if (!f->buf)
	567	PerlIO_alloc_buf(f);
	568	return f->buf;
	569	}
760ac839	570	return NULL;
760ac839	571	}
760ac839	572
6f9d8c32	573	#undef PerlIO_has_base
6f9d8c32	574	int
c78749f2	575	PerlIO_has_base(PerlIO *f)
760ac839	576	{
6f9d8c32	577	if (f)
	578	{
	579	if (!f->buf)
	580	PerlIO_alloc_buf(f);
	581	return f->buf != NULL;
	582	}
760ac839	583	}
	584
	585	#undef PerlIO_puts
	586	int
c78749f2	587	PerlIO_puts(PerlIO f, const char s)
760ac839	588	{
6f9d8c32	589	STRLEN len = strlen(s);
6f9d8c32	590	return PerlIO_write(f,s,len);
760ac839	591	}
	592
	593	#undef PerlIO_eof
6f9d8c32	594	int
c78749f2	595	PerlIO_eof(PerlIO *f)
760ac839	596	{
6f9d8c32	597	if (f)
	598	{
	599	return (f->flags & PERLIO_F_EOF) != 0;
	600	}
	601	return 1;
760ac839	602	}
760ac839	603
8c86a920	604	#undef PerlIO_getname
8c86a920	605	char *
a20bf0c3	606	PerlIO_getname(PerlIO f, char buf)
8c86a920	607	{
	608	#ifdef VMS
	609	return fgetname(f,buf);
	610	#else
961e40ee	611	dTHX;
cea2e8a9	612	Perl_croak(aTHX_ "Don't know how to get file name");
c64afb19	613	return NULL;
8c86a920	614	#endif
	615	}
	616
6f9d8c32	617	#undef PerlIO_ungetc
	618	int
	619	PerlIO_ungetc(PerlIO *f, int ch)
	620	{
	621	PerlIO_debug(__FUNCTION__ " f=%p c=%c\n",f,ch);
	622	if (f->buf && (f->flags & PERLIO_F_RDBUF) && f->ptr > f->buf)
	623	{
	624	*--(f->ptr) = ch;
	625	return ch;
	626	}
	627	return -1;
	628	}
	629
	630	#undef PerlIO_read
	631	SSize_t
	632	PerlIO_read(PerlIO f, void vbuf, Size_t count)
	633	{
	634	STDCHAR buf = (STDCHAR ) vbuf;
	635	if (f)
	636	{
	637	Size_t got = 0;
	638	if (!f->ptr)
	639	PerlIO_alloc_buf(f);
	640
	641	while (count > 0)
	642	{
	643	SSize_t avail = (f->end - f->ptr);
	644	if ((SSize_t) count < avail)
	645	avail = count;
	646	if (avail > 0)
	647	{
	648	Copy(f->ptr,buf,avail,char);
	649	got += avail;
	650	f->ptr += avail;
	651	count -= avail;
	652	buf += avail;
	653	}
	654	if (count && (f->ptr >= f->end))
	655	{
	656	f->ptr = f->end = f->buf;
	657	avail = read(f->fd,f->ptr,f->bufsiz);
	658	if (avail <= 0)
	659	{
	660	if (avail == 0)
	661	f->flags \|= PERLIO_F_EOF;
	662	else if (errno == EINTR)
	663	continue;
	664	else
	665	f->flags \|= PERLIO_F_ERROR;
	666	break;
	667	}
	668	f->end = f->buf+avail;
	669	f->flags \|= PERLIO_F_RDBUF;
	670	}
	671	}
	672	return got;
	673	}
	674	return 0;
	675	}
	676
760ac839	677	#undef PerlIO_getc
6f9d8c32	678	int
c78749f2	679	PerlIO_getc(PerlIO *f)
760ac839	680	{
6f9d8c32	681	STDCHAR buf;
	682	int count = PerlIO_read(f,&buf,1);
	683	if (count == 1)
	684	return buf;
	685	return -1;
760ac839	686	}
	687
	688	#undef PerlIO_error
6f9d8c32	689	int
c78749f2	690	PerlIO_error(PerlIO *f)
760ac839	691	{
6f9d8c32	692	if (f)
	693	{
	694	return f->flags & PERLIO_F_ERROR;
	695	}
	696	return 1;
760ac839	697	}
	698
	699	#undef PerlIO_clearerr
	700	void
c78749f2	701	PerlIO_clearerr(PerlIO *f)
760ac839	702	{
6f9d8c32	703	if (f)
	704	{
	705	f->flags &= ~PERLIO_F_ERROR;
	706	}
760ac839	707	}
	708
	709	#undef PerlIO_setlinebuf
	710	void
c78749f2	711	PerlIO_setlinebuf(PerlIO *f)
760ac839	712	{
6f9d8c32	713	if (f)
	714	{
	715	f->flags &= ~PERLIO_F_LINEBUF;
	716	}
760ac839	717	}
	718
	719	#undef PerlIO_write
5b54f415	720	SSize_t
6f9d8c32	721	PerlIO_write(PerlIO f, const void vbuf, Size_t count)
760ac839	722	{
6f9d8c32	723	const STDCHAR buf = (const STDCHAR ) vbuf;
	724	Size_t written = 0;
	725	PerlIO_debug(__FUNCTION__ " f=%p c=%d\n",f,count);
	726	if (f)
	727	{
	728	if (!f->buf)
	729	PerlIO_alloc_buf(f);
	730	while (count > 0)
	731	{
	732	Size_t avail = f->bufsiz - (f->ptr - f->buf);
	733	if (count < avail)
	734	avail = count;
	735	f->flags \|= PERLIO_F_WRBUF;
	736	if (f->flags & PERLIO_F_LINEBUF)
	737	{
	738	while (avail > 0)
	739	{
	740	int ch = *buf++;
	741	*(f->ptr)++ = ch;
	742	count--;
	743	avail--;
	744	written++;
	745	if (ch == '\n')
	746	PerlIO_flush(f);
	747	}
	748	}
	749	else
	750	{
	751	if (avail)
	752	{
	753	Copy(buf,f->ptr,avail,char);
	754	count -= avail;
	755	buf += avail;
	756	written += avail;
	757	f->ptr += avail;
	758	}
	759	}
	760	if (f->ptr >= (f->buf + f->bufsiz))
	761	PerlIO_flush(f);
	762	}
	763	}
	764	return written;
760ac839	765	}
760ac839	766
6f9d8c32	767	#undef PerlIO_putc
	768	int
	769	PerlIO_putc(PerlIO *f, int ch)
760ac839	770	{
6f9d8c32	771	STDCHAR buf = ch;
6f9d8c32	772	PerlIO_write(f,&ch,1);
760ac839	773	}
760ac839	774
760ac839	775	#undef PerlIO_tell
5ff3f7a4	776	Off_t
c78749f2	777	PerlIO_tell(PerlIO *f)
760ac839	778	{
6f9d8c32	779	Off_t posn = f->posn + (f->ptr - f->buf);
6f9d8c32	780	return posn;
760ac839	781	}
	782
	783	#undef PerlIO_seek
	784	int
c78749f2	785	PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839	786	{
6f9d8c32	787	int code = PerlIO_flush(f);
	788	if (code == 0)
	789	{
	790	f->flags &= ~PERLIO_F_EOF;
	791	f->posn = lseek(f->fd,offset,whence);
	792	if (f->posn == (Off_t) -1)
	793	{
	794	f->posn = 0;
	795	code = -1;
	796	}
	797	}
	798	return code;
760ac839	799	}
	800
	801	#undef PerlIO_rewind
	802	void
c78749f2	803	PerlIO_rewind(PerlIO *f)
760ac839	804	{
6f9d8c32	805	PerlIO_seek(f,(Off_t)0,SEEK_SET);
	806	}
	807
	808	#undef PerlIO_vprintf
	809	int
	810	PerlIO_vprintf(PerlIO f, const char fmt, va_list ap)
	811	{
	812	dTHX;
	813	SV *sv = newSV(strlen(fmt));
	814	char *s;
	815	STRLEN len;
	816	sv_vcatpvf(sv, fmt, &ap);
	817	s = SvPV(sv,len);
	818	return (PerlIO_write(f,s,len) == len) ? 1 : 0;
760ac839	819	}
	820
	821	#undef PerlIO_printf
6f9d8c32	822	int
760ac839	823	PerlIO_printf(PerlIO f,const char fmt,...)
760ac839	824	{
	825	va_list ap;
	826	int result;
760ac839	827	va_start(ap,fmt);
6f9d8c32	828	result = PerlIO_vprintf(f,fmt,ap);
760ac839	829	va_end(ap);
	830	return result;
	831	}
	832
	833	#undef PerlIO_stdoutf
6f9d8c32	834	int
760ac839	835	PerlIO_stdoutf(const char *fmt,...)
760ac839	836	{
	837	va_list ap;
	838	int result;
760ac839	839	va_start(ap,fmt);
760ac839	840	result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
	841	va_end(ap);
	842	return result;
	843	}
	844
	845	#undef PerlIO_tmpfile
	846	PerlIO *
c78749f2	847	PerlIO_tmpfile(void)
760ac839	848	{
6f9d8c32	849	dTHX;
	850	SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
	851	int fd = mkstemp(SvPVX(sv));
	852	PerlIO *f = NULL;
	853	if (fd >= 0)
	854	{
	855	PerlIO *f = PerlIO_fdopen(fd,"w+");
	856	if (f)
	857	{
	858	f->flags \|= PERLIO_F_TEMP;
	859	}
	860	unlink(SvPVX(sv));
	861	SvREFCNT_dec(sv);
	862	}
	863	return f;
760ac839	864	}
	865
	866	#undef PerlIO_importFILE
	867	PerlIO *
c78749f2	868	PerlIO_importFILE(FILE *f, int fl)
760ac839	869	{
6f9d8c32	870	int fd = fileno(f);
6f9d8c32	871	return PerlIO_fdopen(fd,"r+");
760ac839	872	}
	873
	874	#undef PerlIO_exportFILE
	875	FILE *
c78749f2	876	PerlIO_exportFILE(PerlIO *f, int fl)
760ac839	877	{
6f9d8c32	878	PerlIO_flush(f);
6f9d8c32	879	return fdopen(PerlIO_fileno(f),"r+");
760ac839	880	}
	881
	882	#undef PerlIO_findFILE
	883	FILE *
c78749f2	884	PerlIO_findFILE(PerlIO *f)
760ac839	885	{
6f9d8c32	886	return PerlIO_exportFILE(f,0);
760ac839	887	}
	888
	889	#undef PerlIO_releaseFILE
	890	void
c78749f2	891	PerlIO_releaseFILE(PerlIO p, FILE f)
760ac839	892	{
	893	}
	894
6f9d8c32	895	#undef HAS_FSETPOS
	896	#undef HAS_FGETPOS
	897
	898	/======================================================================================/
760ac839	899
	900	#endif /* USE_SFIO */
	901	#endif /* PERLIO_IS_STDIO */
	902
	903	#ifndef HAS_FSETPOS
	904	#undef PerlIO_setpos
	905	int
c78749f2	906	PerlIO_setpos(PerlIO f, const Fpos_t pos)
760ac839	907	{
6f9d8c32	908	return PerlIO_seek(f,*pos,0);
760ac839	909	}
c411622e	910	#else
	911	#ifndef PERLIO_IS_STDIO
	912	#undef PerlIO_setpos
	913	int
c78749f2	914	PerlIO_setpos(PerlIO f, const Fpos_t pos)
c411622e	915	{
2d4389e4	916	#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d	917	return fsetpos64(f, pos);
d9b3e12d	918	#else
c411622e	919	return fsetpos(f, pos);
d9b3e12d	920	#endif
c411622e	921	}
c411622e	922	#endif
760ac839	923	#endif
	924
	925	#ifndef HAS_FGETPOS
	926	#undef PerlIO_getpos
	927	int
c78749f2	928	PerlIO_getpos(PerlIO f, Fpos_t pos)
760ac839	929	{
	930	*pos = PerlIO_tell(f);
	931	return 0;
	932	}
c411622e	933	#else
	934	#ifndef PERLIO_IS_STDIO
	935	#undef PerlIO_getpos
	936	int
c78749f2	937	PerlIO_getpos(PerlIO f, Fpos_t pos)
c411622e	938	{
2d4389e4	939	#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d	940	return fgetpos64(f, pos);
d9b3e12d	941	#else
c411622e	942	return fgetpos(f, pos);
d9b3e12d	943	#endif
c411622e	944	}
c411622e	945	#endif
760ac839	946	#endif
	947
	948	#if (defined(PERLIO_IS_STDIO) \|\| !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
	949
	950	int
c78749f2	951	vprintf(char pat, char args)
662a7e3f	952	{
	953	_doprnt(pat, args, stdout);
	954	return 0; /* wrong, but perl doesn't use the return value */
	955	}
	956
	957	int
c78749f2	958	vfprintf(FILE fd, char pat, char *args)
760ac839	959	{
	960	_doprnt(pat, args, fd);
	961	return 0; /* wrong, but perl doesn't use the return value */
	962	}
	963
	964	#endif
	965
	966	#ifndef PerlIO_vsprintf
6f9d8c32	967	int
8ac85365	968	PerlIO_vsprintf(char s, int n, const char fmt, va_list ap)
760ac839	969	{
	970	int val = vsprintf(s, fmt, ap);
	971	if (n >= 0)
	972	{
8c86a920	973	if (strlen(s) >= (STRLEN)n)
760ac839	974	{
bf49b057	975	dTHX;
	976	PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
	977	my_exit(1);
760ac839	978	}
	979	}
	980	return val;
	981	}
	982	#endif
	983
	984	#ifndef PerlIO_sprintf
6f9d8c32	985	int
760ac839	986	PerlIO_sprintf(char s, int n, const char fmt,...)
760ac839	987	{
	988	va_list ap;
	989	int result;
760ac839	990	va_start(ap,fmt);
760ac839	991	result = PerlIO_vsprintf(s, n, fmt, ap);
	992	va_end(ap);
	993	return result;
	994	}
	995	#endif
	996
c5be433b	997	#endif /* !PERL_IMPLICIT_SYS */
c5be433b	998