/* xlfio.c - xlisp file i/o */
/*		Copyright (c) 1985, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

#include "xlisp.h"
#include <string.h>

/* external variables */
extern LVAL k_direction,k_input,k_output;
extern LVAL s_stdin,s_stdout,true;
extern int xlfsize;

#ifdef BETTERIO
extern LVAL k_io, k_elementtype;
extern LVAL a_fixnum, a_char;
#endif

/* forward declarations */
#ifdef ANSI
LVAL getstroutput(LVAL stream);
LVAL printit(int pflag, int tflag);
LVAL flatsize(int pflag);
#else
FORWARD LVAL getstroutput();
FORWARD LVAL printit();
FORWARD LVAL flatsize();
#endif

/* xread - read an expression */
LVAL xread()
{
	LVAL fptr,eof,val;

	/* get file pointer and eof value */
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
	eof = (moreargs() ? xlgetarg() : NIL);
	if (moreargs()) xlgetarg(); /* toss now unused argument */
	xllastarg();

	/* read an expression */
	if (!xlread(fptr,&val))
		val = eof;

	/* return the expression */
	return (val);
}

/* xprint - built-in function 'print' */
LVAL xprint()
{
	return (printit(TRUE,TRUE));
}

/* xprin1 - built-in function 'prin1' */
LVAL xprin1()
{
	return (printit(TRUE,FALSE));
}

/* xprinc - built-in function princ */
LVAL xprinc()
{
	return (printit(FALSE,FALSE));
}

/* xterpri - terminate the current print line */
LVAL xterpri()
{
	LVAL fptr;

	/* get file pointer */
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
	xllastarg();

	/* terminate the print line and return nil */
	xlterpri(fptr);
	return (NIL);
}

/* printit - common print function */
LOCAL LVAL printit(pflag,tflag)
  int pflag,tflag;
{
	LVAL fptr,val;

	/* get expression to print and file pointer */
	val = xlgetarg();
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
	xllastarg();

	/* print the value */
	xlprint(fptr,val,pflag);

	/* terminate the print line if necessary */
	if (tflag)
		xlterpri(fptr);

	/* return the result */
	return (val);
}

/* xflatsize - compute the size of a printed representation using prin1 */
LVAL xflatsize()
{
	return (flatsize(TRUE));
}

/* xflatc - compute the size of a printed representation using princ */
LVAL xflatc()
{
	return (flatsize(FALSE));
}

/* flatsize - compute the size of a printed expression */
LOCAL LVAL flatsize(pflag)
  int pflag;
{
	LVAL val;

	/* get the expression */
	val = xlgetarg();
	xllastarg();

	/* print the value to compute its size */
	xlfsize = 0;
	xlprint(NIL,val,pflag);

	/* return the length of the expression */
	return (cvfixnum((FIXTYPE)xlfsize));
}

/* xopen - open a file */
LVAL xopen()
{
	char *name,*mode;
	FILE *fp;
	LVAL dir;
#ifdef BETTERIO
	LVAL typ;
#endif

	/* get the file name and direction */
	name = (char *)getstring(xlgetfname());
	if (!xlgetkeyarg(k_direction,&dir))
		dir = k_input;

#ifdef BETTERIO
	if (xlgetkeyarg(k_elementtype,&typ)) {
		if (typ != a_fixnum && typ != a_char)
			xlerror("illegal stream element type",typ);
	}
	else
		typ = a_char;
#endif



	/* get the mode */
	if (dir == k_input)
		mode = "r";
	else if (dir == k_output)
		mode = "w";
#ifdef BETTERIO
	else if (dir == k_io) {
		mode = "r+";	/* try for existing file */
#ifdef __ZTC__
		if ((fp = ((typ == a_fixnum? &osbopen : &osaopen)(name,mode))) != 0)
			return cvfile(fp);
#else
		if ((fp = ((typ == a_fixnum? osbopen : osaopen)(name,mode))) != 0)
			return cvfile(fp);
#endif
		mode = "w+";	/* create new file */
	}
#endif
	else
		xlerror("bad direction",dir);



	/* try to open the file */
#ifdef BETTERIO
#ifdef __ZTC__
	return (((fp = ((typ == a_fixnum ? &osbopen : &osaopen)(name,mode))) != 0)
		? cvfile(fp) : NIL);
#else
	return (((fp = ((typ == a_fixnum ? osbopen : osaopen)(name,mode))) != 0)
		? cvfile(fp) : NIL);
#endif
#else
	return (((fp = osaopen(name,mode)) != 0) ? cvfile(fp) : NIL);
#endif
}

#ifdef BETTERIO
/* xfileposition - get position of file stream */
LVAL xfileposition()
{
	long i,j;
	int t=0;
	LVAL fptr;
	FILE *fp;
	/* get file pointer */
	fp = getfile(fptr = xlgastream());

	/* make sure the file exists */
	if (fp == NULL)
		xlfail("file not open");

/* get current position, adjusting for posible "unget" */
	j = ftell(fp) + (getsavech(fptr) ? -1L : 0L);

	if (moreargs()) { /* must be set position */
		i = getfixnum(xlgafixnum());
		xllastarg();
		setsavech(fptr,'\0');	/* toss unget character, if any */
		fptr->n_sflags = 0;		/* neither reading or writing currently */
		if (i < 0 ||
			(t=fseek(fp,i,SEEK_SET))!=0 ||
			ftell(fp) != i) {
			if (t) return NIL;
			fseek(fp,j,SEEK_SET);
			xlfail("position outside of file");
		}
		return true;
	}

	return (j == -1L ? NIL : cvfixnum(j));
}

/* xfilelength - returns length of file */
LVAL xfilelength()
{
	FILE *fp;
	long i,j;

	/* get file pointer */
	fp = getfile(xlgastream());
	xllastarg();

	/* make sure the file exists */
	if (fp == NULL)
		xlfail("file not open");

	if ((i=ftell(fp)) == -1L ||
		fseek(fp,0L,SEEK_END) ||
		(j = ftell(fp)) == -1L ||
		fseek(fp,i,SEEK_SET)) {
		return NIL;
	}
	
	return cvfixnum(j);
}


#endif


/* xclose - close a file */
LVAL xclose()
{
	LVAL fptr;

	/* get file pointer */
	fptr = xlgastream();
	xllastarg();

	/* make sure the file exists */
	if (getfile(fptr) == NULL)
		xlfail("file not open");

	/* close the file */
	osclose(getfile(fptr));
	setfile(fptr,NULL);

	/* return nil */
	return (NIL);
}

/* xrdchar - read a character from a file */
LVAL xrdchar()
{
	LVAL fptr;
	int ch;

	/* get file pointer */
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
	xllastarg();

	/* get character and check for eof */
	return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
}

/* xrdbyte - read a byte from a file */
LVAL xrdbyte()
{
	LVAL fptr;
	int ch;

	/* get file pointer */
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
	xllastarg();

	/* get character and check for eof */
	return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
}

/* xpkchar - peek at a character from a file */
LVAL xpkchar()
{
	LVAL flag,fptr;
	int ch;

	/* peek flag and get file pointer */
	flag = (moreargs() ? xlgetarg() : NIL);
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
	xllastarg();

	/* skip leading white space and get a character */
	if (flag)
		while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
			xlgetc(fptr);
	else
		ch = xlpeek(fptr);

	/* return the character */
	return (ch == EOF ? NIL : cvchar(ch));
}

/* xwrchar - write a character to a file */
LVAL xwrchar()
{
	LVAL fptr,chr;

	/* get the character and file pointer */
	chr = xlgachar();
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
	xllastarg();

	/* put character to the file */
	xlputc(fptr,getchcode(chr));

	/* return the character */
	return (chr);
}

/* xwrbyte - write a byte to a file */
LVAL xwrbyte()
{
	LVAL fptr,chr;

	/* get the byte and file pointer */
	chr = xlgafixnum();
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
	xllastarg();

	/* put byte to the file */
	xlputc(fptr,(int)getfixnum(chr));

	/* return the character */
	return (chr);
}

/* xreadline - read a line from a file */
LVAL xreadline()
{
	char buf[STRMAX+1],*p,*sptr;
	LVAL fptr,str,newstr;
	int len,blen,ch;

	/* protect some pointers */
	xlsave1(str);

	/* get file pointer */
	fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
	xllastarg();

	/* get character and check for eof */
	len = blen = 0; p = buf;
	while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {

		/* check for buffer overflow */
		if (blen >= STRMAX) {
			newstr = newstring(len + STRMAX + 1);
			sptr = getstring(newstr); *sptr = '\0';
			if (str) strcat((char *)sptr,(char *)getstring(str));
			*p = '\0'; strcat((char *)sptr,(char *)buf);
			p = buf; blen = 0;
			len += STRMAX;
			str = newstr;
		}

		/* store the character */
		*p++ = ch; ++blen;
	}

	/* check for end of file */
	if (len == 0 && p == buf && ch == EOF) {
		xlpop();
		return (NIL);
	}

	/* append the last substring */
	if (str == NIL || blen) {
		newstr = newstring(len + blen + 1);
		sptr = getstring(newstr); *sptr = '\0';
		if (str) strcat((char *)sptr,(char *)getstring(str));
		*p = '\0'; strcat((char *)sptr,(char *)buf);
		str = newstr;
	}

	/* restore the stack */
	xlpop();

	/* return the string */
	return (str);
}


/* xmkstrinput - make a string input stream */
LVAL xmkstrinput()
{
	int start,end,len,i;
	char *str;
	LVAL string,val;

	/* protect the return value */
	xlsave1(val);
	
	/* get the string and length */
	string = xlgastring();
	str = getstring(string);
	len = getslength(string) - 1;

	/* get the starting offset */
	if (moreargs()) {
		val = xlgafixnum();
		start = (int)getfixnum(val);
	}
	else start = 0;

	/* get the ending offset */
	if (moreargs()) {		/* TAA mod to allow NIL for end offset */
		val = nextarg();
		if (val == NIL) end = len;
		else if (fixp(val)) end = (int)getfixnum(val);
		else xlbadtype(val);
	}
	else end = len;
	xllastarg();

	/* check the bounds */
	if (start < 0 || start > len)
		xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
	if (end < 0 || end > len)
		xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));

	/* make the stream */
	val = newustream();

	/* copy the substring into the stream */
	for (i = start; i < end; ++i)
		xlputc(val,str[i]);

	/* restore the stack */
	xlpop();

	/* return the new stream */
	return (val);
}

/* xmkstroutput - make a string output stream */
LVAL xmkstroutput()
{
	return (newustream());
}

/* xgetstroutput - get output stream string */
LVAL xgetstroutput()
{
	LVAL stream;
	stream = xlgaustream();
	xllastarg();
	return (getstroutput(stream));
}

/* xgetlstoutput - get output stream list */
LVAL xgetlstoutput()
{
	LVAL stream,val;

	/* get the stream */
	stream = xlgaustream();
	xllastarg();

	/* get the output character list */
	val = gethead(stream);

	/* empty the character list */
	sethead(stream,NIL);
	settail(stream,NIL);

	/* return the list */
	return (val);
}
#ifdef ENHFORMAT
/* decode prefix parameters and modifiers for a format directive */
#ifdef ANSI
static char *decode_pp(char *fmt, FIXTYPE *pp, int maxnpp, 
                       int *npp, int *colon, int *atsign)
#else
LOCAL char *decode_pp( fmt, pp, maxnpp, npp, colon, atsign )
char	*fmt;
FIXTYPE	pp[];			/* prefix parameters */
int		maxnpp;			/* maximum number of them */
int		*npp;			/* actual number of them */
int		*colon;			/* colon modifier given? */
int		*atsign;		/* atsign modifier given? */
#endif
{
	int gotpp = 0;		/* set to 1 when pp encountered */
	
	*npp = 0;
	*colon = 0;
	*atsign = 0;
	pp[0] = 0;
	do {
		if( *fmt == ':' )
			*colon = 1;
		else if( *fmt == '@' )
			*atsign = 1;
		else if( *colon || *atsign )	/* nothing else may follow : or @ */
		   break;
		else if( isdigit(*fmt) ) {
			pp[*npp] = (pp[*npp] * 10) + (int)(*fmt - '0');
			gotpp = 1;
		}
		else if( *fmt == ',' ) {
			if( ++(*npp) >= maxnpp )
				xlerror("too many prefix parameters in format",cvstring(fmt));
			pp[*npp] = 0;
			gotpp = 1;
		}
		else if( *fmt == '\'' ) {
			pp[*npp] = *(++fmt);
			gotpp = 1;
		}
		else if( *fmt == 'v' || *fmt == 'V' ) {
			pp[*npp] = getfixnum(xlgafixnum());
			gotpp = 1;
		}
		else 
			break;
		fmt++;
	} while( 1 );
	*npp += gotpp;				/* fix up the count */
	return fmt;
}

#define mincol	pp[0]
#define colinc	pp[1]
#define minpad	pp[2]
#define padchar pp[3]

/* opt_print - print a value using prefix parameter options */
#ifdef ANSI
static VOID opt_print(LVAL stream, LVAL val, int pflag, FIXTYPE *pp,
					int npp, int colon, int atsign)
#else
LOCAL VOID opt_print(stream,val,pflag,pp,npp,colon,atsign)
LVAL	stream;
LVAL	val;
int		pflag;			/* quoting or not */
FIXTYPE	pp[];			/* prefix parameters */
int		npp;			/* number of them */
int		colon;			/* colon modifier given? */
int		atsign;			/* at-sign modifier given? */
#endif
{
	int flatsize;
	int i;
	
	switch( npp ) {		/* default values of prefix parameters */
	case 0: mincol = 0;			 /* see CLtL, page 387 */
	case 1: colinc = 1;
	case 2: minpad = 0;
	case 3: padchar = ' ';
	}
	if( colinc <= 1 )
			colinc = 1;
	if( mincol < minpad )
			mincol = minpad;

	if( mincol > 0 && atsign ) {		/* padding may be required on left */
		xlfsize = 0;
		xlprint(NIL,val,pflag);			/* print to get the flat size */
		flatsize = xlfsize;
		for( i = 0; i < minpad; flatsize++, i++ )
			xlputc(stream,(int)padchar);
		while( flatsize < mincol ) {
			for( i = 0; i < colinc; i++ )
				xlputc(stream,(int)padchar);
			flatsize += (int)colinc;
		}
	}

	xlfsize = 0;				/* print the value */
	if( colon && val == NIL )
		xlputstr(stream,"()");
	else
		xlprint(stream,val,pflag);
	flatsize = xlfsize;
	
	if( mincol > 0 && !atsign ) {		/* padding required on right */
		for( i = 0; i < minpad; flatsize++, i++ )
			xlputc(stream,(int)padchar);
		while( flatsize < mincol ) {
			for( i = 0; i < colinc; i++ )
				xlputc(stream,(int)padchar);
			flatsize += (int)colinc;
		}
	}
}

#define MAXNPP	4
#endif

/* xformat - formatted output function */
LVAL xformat()
{
	char *fmt;
	LVAL stream,val;
	int ch;
#ifdef ENHFORMAT
	int npp;			/* number of prefix parameters */
	FIXTYPE pp[MAXNPP];		/* list of prefix parameters */
	int colon, atsign;	/* : and @ modifiers given? */
#endif

	xlsave1(val);						/* TAA fix */

	/* get the stream and format string */
	stream = xlgetarg();
	if (stream == NIL) {
		val = stream = newustream();
	}
	else {
		if (stream == true)
			stream = getvalue(s_stdout);
																/* fix from xlispbug.417 */
		else if (streamp(stream)) {		/* copied from xlgetfile() */
				if (getfile(stream) == NULL)
						xlfail("file not open");
		}
		else if (!ustreamp(stream))
				xlbadtype(stream);
		val = NIL;
	}
	fmt = getstring(xlgastring());

	/* process the format string */
	while ((ch = *fmt++) != 0)
		if (ch == '~') {
#ifdef ENHFORMAT
			fmt = decode_pp( fmt, pp, MAXNPP, &npp, &colon, &atsign );
#endif
			switch (*fmt++) {
			case '\0':
				xlerror("expecting a format directive",cvstring(fmt-1));
			case 'a': case 'A':
#ifdef ENHFORMAT
				opt_print(stream,xlgetarg(),FALSE,pp,npp,colon,atsign);
#else
				xlprint(stream,xlgetarg(),FALSE);
#endif
				break;
			case 's': case 'S':
#ifdef ENHFORMAT
				opt_print(stream,xlgetarg(),TRUE,pp,npp,colon,atsign);
#else
				xlprint(stream,xlgetarg(),TRUE);
#endif
				break;
			case '%':
#ifdef ENHFORMAT
				if( pp[0] <= 0 ) pp[0] = 1;
				while( (pp[0])-- > 0 )
					xlterpri(stream);
#else
				xlterpri(stream);
#endif
				break;
			case '~':
#ifdef ENHFORMAT
				if( pp[0] <= 0 ) pp[0] = 1;
				while( (pp[0])-- > 0 )
					xlputc(stream,'~');
#else
				xlputc(stream,'~');
#endif
				break;
			case '\n':
#ifdef ENHFORMAT
				if( colon )
					break;
				if( atsign )
					 xlterpri(stream);
#endif
				while (*fmt && *fmt != '\n' && isspace(*fmt))
					++fmt;
				break;
			default:
				xlerror("unknown format directive",cvstring(fmt-1));
			}
		}
		else
			xlputc(stream,ch);
		
	/* unprotect */
	xlpop();

	/* return the value */
	return (val ? getstroutput(val) : NIL);
}


/* getstroutput - get the output stream string (internal) */
LOCAL LVAL getstroutput(stream)
  LVAL stream;
{
	char *str;
	LVAL next,val;
	int len,ch;

	/* compute the length of the stream */
	for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
		++len;

	/* create a new string */
	val = newstring(len + 1);
	
	/* copy the characters into the new string */
	str = getstring(val);
	while ((ch = xlgetc(stream)) != EOF)
		*str++ = ch;
	*str = '\0';

	/* return the string */
	return (val);
}