scsh-0.5/scsh/fdports1.c

/* This file contains the code for doing the scsh file ports stuff.
** Copyright (c) 1993, 1994 by Olin Shivers.
**
** Note that this code mutates Scheme records -- it has the layout
** of fdports and their data records wired in. This is somewhat fragile.
*/

/* A note on the clearerr() calls herein: SunOS stdio input routines, 
** contrary to POSIX, will return EOF if the stream's EOF flag is set,
** without trying to read the stream. This is a lose for tty's, which
** can frequently still be read from after the first EOF (e.g., if you
** type a ^D to bag out of a breakpoint, you would like the terminal
** input port to not shut down forever.)
**
** To fix this lossage, we are careful to call clearerr() before every
** input stream op.
*/

/* We maintain the following invariant: every open port has a FILE*
** associated with it.
*/
#include "sysdep.h"
#include <stdio.h>
#include <fcntl.h>
#include <unistd.h>
#include <stdlib.h>
#include <errno.h>
#include "cstuff.h"
#define NUM_FDPORTS 256
#include "fdports.h"
#include "machine/stdio_dep.h"

/* Make sure our exports match up w/the implementation: */
#include "fdports1.h"

extern int errno;

/* Maps fd's to FILE*'s. */
static FILE *fstar_cache[NUM_FDPORTS] = {NULL};

/* Maps fd's to ports. */
static scheme_value fdports[NUM_FDPORTS] = {SCHFALSE};

void init_fdports(void)
{
    int i = NUM_FDPORTS;

#ifdef linux
    /* Gross hack to cover for Linux lossage. -Olin */
    extern void remove_bone_from_head_of_linux_libc (void);
    remove_bone_from_head_of_linux_libc();
#endif

    while( i-- ) fdports[i] = SCHFALSE;

    /* Specially hack stdio. */
    fstar_cache[fileno(stdin)]  = stdin;
    fstar_cache[fileno(stdout)] = stdout;
    fstar_cache[fileno(stderr)] = stderr;
    }

/* (maybe_fdes2port fd)
** Return: the port if there is one allocated; otherwise #f.
** If a port is returned, the revealed count is NOT incremented.
*/
scheme_value maybe_fdes2port(int fd)
{
    if( fd < 0 || fd >= NUM_FDPORTS )
	return SCHFALSE;
	
    return fdports[fd];
    }

#if 0
/* Bogus old code. We now compute the mode string from the actual fd. */
static char const *mode2string(int mode)
{
    if( mode == 0 ) return "r";
    else if( mode == 1 ) return "w";
    else if( mode == 2 ) return "r+";
    else return "x"; /* What??? */
    }
#endif

static char const *fdes_modestr(int fd)
{
    int flags = fcntl(fd,F_GETFL);

    if( flags == -1 ) return NULL;
    flags &= O_ACCMODE;

    if( flags == O_WRONLY ) return "w";
    else if( flags == O_RDONLY ) return "r";
    else if( flags == O_RDWR ) return "r+";

    fputs("That's impossible.\n", stderr);
    abort();
    _exit(-1);
    /*NOTREACHED*/
    }

/* Returns a char, #f for EOF, or errno. */
scheme_value fdport_getchar(scheme_value data)
{
    int fd = EXTRACT_FIXNUM(*PortData_Fd(data));
    FILE *f = fstar_cache[fd];
    int c;
    
    clearerr(f);
    c = getc(f);

    if( EOF == c )
	return ferror(f) ? ENTER_FIXNUM(errno) : SCHFALSE;
    else
	return ENTER_CHAR(c);
    }

int fdport_putchar(scheme_value data, char c)
{
    int fd = EXTRACT_FIXNUM(*PortData_Fd(data));
    FILE *f = fstar_cache[fd];
    int retval = putc(c,f);
    return (retval == EOF) ? errno : 0;
    }


/* Not POSIX, so we punt to an OS-specific routine. */
scheme_value fdport_char_readyp(scheme_value data)
{
    extern scheme_value stream_char_readyp(FILE *);
    return stream_char_readyp(fstar_cache[EXTRACT_FIXNUM(*PortData_Fd(data))]);
    }


int flush_fdport(scheme_value data)
{
    FILE *f = fstar_cache[EXTRACT_FIXNUM(*PortData_Fd(data))];
    return fflush(f) ? errno : 0;
    }

/* This is actually just fflush(NULL), but apparently the pinheads
** at Sun can't be bothered to implement ANSI C or POSIX, so this op
** cleverly dumps core. Hence we do this incomplete approximation.
*/

int flush_all_ports(void)
{
    int i;
    for(i=0; i<NUM_FDPORTS; i++)
	if(fstar_cache[i]) fflush(fstar_cache[i]);
    return 0;
/*  return fflush(NULL) ? errno : 0;  THE REAL SOLUTION.*/
    }

int seek_fdport(scheme_value data, off_t offset, int whence, int *newpos)
{
    FILE *f = fstar_cache[EXTRACT_FIXNUM(*PortData_Fd(data))];
    *PortData_Peek(data) = SCHFALSE; /* Flush buffered data. */

    if( fseek(f, offset, whence) )		/* seek */
	{ *newpos = 0; return errno; }

    *newpos = ftell(f);				/* tell */
    return (*newpos < 0) ? errno : 0;
    }


int tell_fdport( scheme_value data, int *newpos )
{
    FILE *f = fstar_cache[EXTRACT_FIXNUM(*PortData_Fd(data))];
    *newpos = ftell(f);
    return (*newpos < 0) ? errno : 0;
    }
    

int set_fdbuf( scheme_value data, int policy, int bufsize )
{
    FILE *f = fstar_cache[EXTRACT_FIXNUM(*PortData_Fd(data))];
    int size = (bufsize < 0) ? BUFSIZ : bufsize;
    return setvbuf(f, NULL, policy, size) ? errno : 0;
    }

int close_fdport(scheme_value port_data)
{
    if( *PortData_Closed(port_data) == SCHFALSE ) {
	int fd = EXTRACT_FIXNUM(*PortData_Fd(port_data));
	FILE *f = fstar_cache[fd];

	if( fclose(f) ) return errno;

	*PortData_Fd(port_data) = SCHFALSE;
	fdports[fd] = SCHFALSE;
	*PortData_Closed(port_data) = SCHTRUE;
	*PortData_Peek(port_data) = SCHFALSE;
	fstar_cache[fd] = NULL;
	return 0;
	}
    else return EBADF; /* Already closed. */
    }


static int cloexec_fdport(scheme_value port_data)
{
    int fd = EXTRACT_FIXNUM(*PortData_Fd(port_data));

    return fcntl(fd, F_SETFD, FD_CLOEXEC) ? errno : 0;
    }


int install_port(int fd, scheme_value port, int revealed)
{
    FILE *stream;
    const char *modestr;

    if( fd < 0 || fd >= NUM_FDPORTS ) return -1;
    if( fdports[fd] != SCHFALSE ) return -2;
    if( !(modestr = fdes_modestr(fd)) )
	return -3;

    fdports[fd] = port;

    if( !revealed )
      if( set_cloexec(fd, 1) ) return errno;

    if( fstar_cache[fd] ) return 0; /* A hack mainly for stdio. */

    fstar_cache[fd] = stream = fdopen(fd, modestr);
    return stream ? 0 : errno;
    }


FILE *fdes2fstar(int fd)
{
    if( fstar_cache[fd] ) return fstar_cache[fd];
    else {
	const char *modestr = fdes_modestr(fd);
	return modestr ? fdopen(fd, modestr) : NULL;
	}
    }

/* fd_from's FILE* structure is changed to be fd_to's FILE* structure.
** So buffered data isn't lost. Return 0 on failure.
** Rather non-portable.
*/
static int move_fstar(int fd_from, int fd_to)
{
    FILE *f1 = fdes2fstar(fd_from);
    if( !f1 ) return 0;
    setfileno(f1, fd_to);
    fstar_cache[fd_from] = NULL;
    fstar_cache[fd_to] = f1;
    return 1;
    }


/* Move port so that it's underlying file descriptor is fd.
** The port's underlying FILE* is also shifted over, so that
** buffered data isn't lost on a shift. Return 0 on success.
*/
int move_fdport(int fd, scheme_value port, int new_revealed)
{
    scheme_value port_data = *Port_PortData(port);
    int old_fd = EXTRACT_FIXNUM(*PortData_Fd(port_data));

    if( fd < 0 || fd >= NUM_FDPORTS ) return 1;

    /* You are allowed to "move" a port to its current fd.
       Otherwise, the fd must be unallocated. Kluge. */

    if( fdports[fd] != port ) {
	if( fdports[fd] != SCHFALSE ) return 1; /* Target already allocated. */

	if( !move_fstar(old_fd, fd) ) return 1;
	
	fdports[fd] = port;
	fdports[old_fd] = SCHFALSE;
	*PortData_Fd(port_data) = ENTER_FIXNUM(fd);
	}

    /* Unreveal the port by shifting the revealed count
       over to the old-revealed count. */
    *PortData_OldRev(port_data) = ENTER_FIXNUM(EXTRACT_FIXNUM(*PortData_OldRev(port_data))+
					 EXTRACT_FIXNUM(*PortData_Rev(port_data)));
    *PortData_Rev(port_data) = ENTER_FIXNUM(new_revealed);
    if( !new_revealed ) return set_cloexec(fd, 1);
    return 0;
    }

/* Scan the fdports vector after a gc. Uncopied unrevealed ports 
** have their fds closed. The fdports vec is updated with the copy.
*/
#ifdef TEST_GC
void post_gc_fdports(void) {}
#else
void post_gc_fdports(void)
{
    int fd;

#ifdef NOISY_FDGC
    fputs("{GC", stderr); fflush(stderr);
#endif
    for(fd=0; fd<NUM_FDPORTS; fd++) {

	scheme_value port = fdports[fd];
	if(STOBP(port)) {
	    long header = STOB_HEADER(port);
	    if(STOBP(header)) {
#ifdef NOISY_FDGC
		fprintf(stderr, "Copying port[fd] %d[%d] header %d\n",
			port, fd, header);
		fflush(stderr);
#endif
		/* Port was copied, so update fdports entry. */
		fdports[fd] = header;
		}
	
	    else {
		/* Port wasn't copied -- is garbage.
		   If fd unrevealed, close it. */
		int rev = EXTRACT_FIXNUM(*PortRev(port));
#ifdef NOISY_FDGC
		fprintf(stderr, "GC'ing %srevealed port[fd] %d[%d]\n",
			rev == 0 ? "un" : "",
			port, fd);
		fflush(stderr);
#endif
		if( rev == 0 )
		  /* Close, even if interrupted -- GC's must be atomic. */
		  while( EINTR == close_fdport(*Port_PortData(port)) );

		fdports[fd] = SCHFALSE; /* Drop the port. */
		}
	    }
	}
#ifdef NOISY_FDGC
    fputs("}", stderr); fflush(stderr);
#endif
    }
#endif

#define Min(a,b) (((a) < (b)) ? (a) : (b))	/* Not a function. */

/* Note the clearerr() call. This is so a ^D on a tty input stream
** doesn't shut the stream down forever. SunOS doesn't handle this according
** to POSIX spec, so we have to explicitly hack this case.
*/

static int read_stream_substring(scheme_value buf, int start, int end, FILE *f)
{
  char *p = StrByte(buf,start);
  int len = end-start;

  clearerr(f);

  /* If there's data in the buffer, use it. */

  if (fbufcount(f) > 0)
    return fread(p, 1, Min(len, fbufcount(f)), f);

  /* Otherwise, do a read. */
  return read(fileno(f), p, len);
}

#define MIN(a,b) (((a) < (b)) ? (a) : (b))	/* Not a function. */

int read_fdport_substring(scheme_value buf, int start, int end, scheme_value data)
{
    scheme_value peek = *PortData_Peek(data);
    FILE *f = fstar_cache[EXTRACT_FIXNUM(*PortData_Fd(data))];

    clearerr(f); /* SunOS sux. */

    /* If there's a peek char, then we'll use it and
       whatever is buffered in the FILE*. */

    if( IsChar(peek) ) {
	int len = end-start;
	if( len > 0 ) {
	    char *p = StrByte(buf,start);
	    *p++ = EXTRACT_CHAR(peek);
            *PortData_Peek(data) = SCHFALSE;
	    return 1 + fread(p, 1, MIN(len-1, fbufcount(f)), f);
	    }
	else return 0;
	}

    /* Otherwise, just do a read_stream_substring. */
    return read_stream_substring(buf, start, end, f);
    }


/* We assume either fileno(f) does blocking i/o or f is unbuffered. */

int write_fdport_substring(scheme_value buf, int start, int end, scheme_value data)
{
    FILE *f = fstar_cache[EXTRACT_FIXNUM(*PortData_Fd(data))];
    int nbytes = end - start;
    int retval = fwrite(StrByte(buf,start), 1, nbytes, f);
    return (retval < nbytes) ? -1 : retval; /* -1: error, otw numwritten */
    }

/* 1st return value says why we terminated the read:
** - integer errno if error.
** - char c if string terminated by char c (which is consumed).
** - eof object if string terminated by EOF
** - #f if buf overflow.
**
** 2nd return value is num chars read into BUF.
**
** GOBBLE boolean says whether or not to read a terminating delimiter char
**	or just leave it in the input stream.
**
** N.B.:
** - This code is dependent on the representation of scsh's char-sets.
**   We assume they are 256-elt strings. If this changes, we'd have to
**   rewrite the code.
** - This procedure is made more complex by the fact that we may have to take
**   the first char read from the *port's* peek-char slot.
** - buffer-full/terminated-char ties are broken in favor of successful
**   termination.
*/

scheme_value read_delim(const char *delims, char *buf, int gobble,
			scheme_value port, int start, int end,
			int *nread)
{

    scheme_value data  = *Port_PortData(port);
    scheme_value peekc = *PortData_Peek(data);
    int fd = EXTRACT_FIXNUM(*PortData_Fd(data));
    FILE *f = fstar_cache[fd];
    char *cptr   = buf+start-1, /* Location of last char deposited. */
         *bufend = buf+end-1;   /* Last writeable position. */
    
    /* This chunk of code is necessary because we have to check
    ** the port's one-char pushback slot before going to the port's
    ** stdio FILE*. Yech.
    */
    if( IsChar(peekc) ) {
	char c = EXTRACT_CHAR(peekc);
	if( delims[c]  ) {		/* Is c in cset? */
	    if( gobble ) *PortData_Peek(data) = SCHFALSE;
	    *nread = 0;
	    return peekc;
	    }
	else if( start >= end ) {
	    *nread = 0;			/* Overflow. */
	    return SCHFALSE;
	    }
	else {
	    *++cptr = c;
	    *PortData_Peek(data) = SCHFALSE;
	    }
	}

    clearerr(f);

    while( 1 ) {
	int c = getc(f);

	if( EOF == c ) {		/* Terminal case: EOF or error. */
	    *nread = 1 + cptr - buf - start;
	    return ferror(f) ? ENTER_FIXNUM(errno) : SCHEOF;
	    }

	else if( delims[c] ) {		/* Terminal case: delimiter char. */
	    scheme_value ch = ENTER_CHAR(c);
	    *nread = 1 + cptr - buf - start;
	    if( !gobble ) *PortData_Peek(data) = ch;
	    return ch;
	    }

	else if( cptr >= bufend ) {	/* Terminal case: buffer overflow. */
	    *PortData_Peek(data) = ENTER_CHAR(c);	/* Put C back. */
	    *nread = end-start;
	    return SCHFALSE;
	    }
	
	else *++cptr = c;
	}
    }


scheme_value skip_chars(const char *skipchars, scheme_value port,  int *nread)
{

    scheme_value data  = *Port_PortData(port);
    scheme_value peekc = *PortData_Peek(data);
    int fd = EXTRACT_FIXNUM(*PortData_Fd(data));
    FILE *f = fstar_cache[fd];
    int nr = 0; /* Number of skip chars read. */

    /* This chunk of code is necessary because we have to check
    ** the port's one-char pushback slot before going to the port's
    ** stdio FILE*. Yech.
    */
    if( IsChar(peekc) ) {
	int c = EXTRACT_CHAR(peekc);
	if( skipchars[c]  ) {		/* Is c in cset? */
	    *PortData_Peek(data) = SCHFALSE;
	    nr = 1;
	    }
	else {
	    *nread = 0;
	    return SCHFALSE;
	    }
	}

    clearerr(f);

    while( 1 ) {
	int c = getc(f);

	if( EOF == c ) {		/* Terminal case: EOF or error. */
	    *nread = nr;
	    return ferror(f) ? ENTER_FIXNUM(errno) : SCHFALSE;
	    }

	else if( !skipchars[c] ) {	/* Terminal case: non-skip char. */
	    *PortData_Peek(data) = ENTER_CHAR(c);
	    *nread = nr;
	    return SCHFALSE;
	    }
	nr++;
	}
    }

/* Why, you might ask, do I push back the final char using the Scheme port
** instead of using ungetc()? Because ungetc() isn't guaranteed to work for
** unbuffered ports. This is regrettable, because it causes C stdio clients
** that are ignorant of the Scheme port machinery to miss this char. No
** real help for it.
*/