/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/**************\
* *
* KlO Stream *
* BODY *
* *
\**************/
#include "EXTERN.h"
#include <signal.h>
#include <fcntl.h>
#ifdef SYSV
#include <unistd.h>
#endif /* SYSV */
#include <sys/types.h>
#include <ctype.h>
#include <sys/time.h>
#include <sys/stat.h>
#ifdef NEED_SELECT_H
#include <sys/select.h>
#endif
#include "klone.h"
#include "kl_number.h"
#include "kl_atom.h"
#include "kl_list.h"
#include "kl_string.h"
#include "kl_func.h"
#include "klgeneric.h"
#include "klnet.h"
#include "klparser.h"
#include "INTERN.h"
#include "kl_stream.h"
#include <errno.h>
KlO KlStreamToStringCoerce();
extern KlStream KlSocketMake();
extern KlStream KlSocketAccept();
/* direction of files:
* 0 = closed
* 1 = read
* 2 = write
* ==> 3 read&write
*/
char *KlStreamDirectionsText[] = {"closed", "read", "write", "read+write"};
/* constructor for Files
*/
KlStream
KlStreamMake(fd, direction, name)
FILE *fd;
int direction;
char *name;
{
KlStream obj;
obj = (KlStream) KlOMake(KlStreamType);
obj->subtype = KlStreamFileType;
obj->fd = fd;
obj->write_fd = 0;
obj->direction = direction;
obj->parse_state = 0;
obj->parse_dirty = 0;
obj->parse_disabled = 0;
obj->parse_bufferized = 0; /* can be turned to 1 by load */
obj->read_expr = 0;
obj->name = (char *) Malloc(strlen(name) + 1);
strcpy(obj->name, name);
obj->blocking = 1;
obj->blocking_write = 1;
return obj;
}
/* constructor for Strings
*/
KlStreamString
KlStreamStringMake(klstring, direction)
KlString klstring;
int direction;
{
KlStreamString obj;
obj = (KlStreamString) KlOMake(KlStreamType);
obj->subtype = KlStreamStringType;
KlIncRef(obj->klstring = klstring);
obj->direction = direction;
obj->parse_state = 0;
obj->parse_dirty = 0;
obj->parse_disabled = 0;
obj->read_expr = 0;
obj->cursor = 0;
#ifdef USE_STANDARD_MALLOC
obj->limit = (klstring->string ? KlModStringLength(klstring) + 1 : 0);
#else /* !USE_STANDARD_MALLOC */
#ifdef DO_NOT_REDEFINE_MALLOC
if (obj->type == KlStringType && KlOIsInMallocSpace(klstring->string))
/* optimisation: if we can determine the bucket size, use it! */
obj->limit = (klstring->string ? KlMallocedSize(klstring->string) : 0);
else /* let realloc do the work */
obj->limit = (klstring->string ? KlModStringLength(klstring) + 1 : 0);
#else /* !DO_NOT_REDEFINE_MALLOC */
/* here we are sure all malloc go through our malloc */
if (!KlHasTrait(klstring, KlTrait_unreallocable))
obj->limit = (klstring->string ? KlMallocedSize(klstring->string) : 0);
else
obj->limit = (klstring->string ? KlModStringLength(klstring) + 1 : 0);
#endif /* DO_NOT_REDEFINE_MALLOC */
#endif /* !USE_STANDARD_MALLOC */
return obj;
}
/* KlOpen
* opening a new stream
* (open filename &key :direction :if-exists :type :error) [646]
*
* creates a stream by opening the file filename. keywords can be:
* :direction :output, :input (default), or :io (both)
* :if-exists :overwrite, :supersede, :error or :append (default)
* what to do if file exists.
* already and we open it in :output or :io mode)
* :type :file (default) or :string. The string type is a string that
* can be written to and read from by I/O primitives, but can
* be still used as a string.
* Also can be :tcp for tcp socket, :udp for udp socket
* :pipe creates a pipe with both ends separated
* in this case filename will just be used as a label when
* printing the stream
* :buffered can be t (default) or nil
* :writer file to open for writing, if :direction :io and write channel
* is different from read channel
* :blocking can be t (default) or (), in which case FD_NDELAY is set
* :error if an error happens, returns the evaluation of argument
* instead of calling KlE_ERROR_OPENING_FILE. Note that since
* open evaluates its arguments, you need to quote the
* expression
* NOTE: filename must be a string or a listen-ing socket, in which case
* open does an accept call on it and return the actual socket. In this case
* :type is ignored, but direction, buffered, blocking, error are not
*/
/* list of valid parameters to keywords. see at the end of this file */
static KlKeyword
*KlOpenKV_if_exists,
*KlOpenKV_direction,
*KlOpenKV_filetype;
KlStream
KlOpen(argc, argv)
int argc;
KlO *argv;
{
KlO direction, if_exists, filetype, buffered, blocking, error;
KlString writer;
KlString filename;
int no_delay;
KlParseKeywords(argc, argv, 1);
direction = KlKeyVal(KlK_direction, KlK_input);
if_exists = KlKeyVal(KlK_if_exists, KlK_append);
filetype = KlKeyVal(KlK_type, KlK_file);
buffered = KlKeyVal(KlK_buffered, TRU);
writer = (KlString) KlKeyVal(KlK_writer, 0);
blocking = KlKeyVal(KlK_blocking, TRU);
error = KlKeyVal(KlK_error, 0);
KlCheckUnvalidKeywords(argc, argv, 1);
/* check the validity of the arguments to the keywords. */
if_exists = KlCheckKeywordValue(KlK_if_exists, if_exists,
KlOpenKV_if_exists);
direction = KlCheckKeywordValue(KlK_direction, direction,
KlOpenKV_direction);
/* this chek is not needed actually, since all bad values are trapped ...
filetype = KlCheckKeywordValue(KlK_type, filetype, KlOpenKV_filetype);
*/
no_delay = KlFalseP(blocking);
if (!KlIsAString(argv[0])) {
/* a socket? ==> accept call */
if (KlIsAStream(argv[0]) &&
(((KlStream) (argv[0]))->subtype & 12)) {
return KlSocketAccept(argv[0], direction, buffered, blocking, error);
} else { /* else error */
KlMustBeString(argv[0], 0);
}
}
filename = (KlString) argv[0];
if (filetype == (KlO) KlK_file) { /* file type */
KlStream stream;
char *mode;
FILE *fd, *write_fd = 0;
if (direction == (KlO) KlK_output) {
mode = (if_exists == (KlO) KlK_overwrite ? "r+" :
if_exists == (KlO) KlK_supersede ? "w" : "a");
} else if (direction == (KlO) KlK_io) {
mode = (if_exists == (KlO) KlK_overwrite ? "r+" :
if_exists == (KlO) KlK_supersede ? "w+" : "a+");
if (writer) {
KlMustBeString(writer, KlPosition(argc, argv, KlK_writer) + 1);
if (writer->string[0] == '~') {
writer = KlExpandTildeForFiles(writer->string);
}
if (!(write_fd = fopen(writer->string, mode))) {
return KlOpenError(error, writer, KlK_output, 1);
}
mode = "r";
}
} else { /* input */
mode = "r";
}
/* check for exclusion, :if-exists :error */
if (*mode == 'a' && if_exists == (KlO) KlK_error) {
int o_mode = (mode[1] == '+' ?
O_CREAT | O_EXCL | O_RDWR :
O_CREAT | O_EXCL | O_WRONLY);
int fdes = open((filename->string[0] == '~'
? KlExpandTildeForFiles(filename->string)->string
: filename->string), o_mode, 0666);
if (fdes < 0 || !(fd = fdopen(fdes, mode))) { /* error, existed */
return KlOpenError(error, filename, direction, 1);
}
} else if (!(fd = fopen( /* normal open */
(filename->string[0] == '~'
? KlExpandTildeForFiles(filename->string)->string
: filename->string),
mode))) {
return KlOpenError(error, filename,
write_fd ? KlK_input : (KlKeyword) direction, 1);
}
stream = KlStreamMake(fd,
direction == (KlO) KlK_output ? 2 :
direction == (KlO) KlK_io ? 3 :
1,
filename->string);
if (write_fd) {
stream->write_fd = write_fd;
}
if (buffered == NIL) { /* unbuffer stream */
setbuf(((stream->direction & KlStreamOWRITE) && write_fd
? write_fd
: fd),
0);
}
if (direction == (KlO) KlK_output
&& if_exists == (KlO) KlK_overwrite) {
fseek(fd, 0L, 0);
if (write_fd) {
fseek(write_fd, 0L, 0);
}
}
if (no_delay) {
KlSetFILENoBlocking(fd, 1, &(stream->blocking));
if (writer)
KlSetFILENoBlocking(write_fd, 1, &(stream->blocking_write));
}
return stream;
} else if (filetype == (KlO) KlK_string) { /* string stream */
KlStreamString stream;
KlMustBeAModifiableString(filename, 0);
stream =
KlStreamStringMake(filename,
direction == (KlO) KlK_output ? 2 :
direction == (KlO) KlK_io ? 3 :
1);
if (direction == (KlO) KlK_output
|| direction == (KlO) KlK_io) {
if (if_exists == (KlO) KlK_append) {
stream->cursor = KlModStringLength(stream->klstring);
} else if (if_exists == (KlO) KlK_supersede) {
stream->klstring->string[0] = '\0';
KlModStringSetLength(stream->klstring, 0);
}
/* overwrite ==> cursor = 0 */
}
return (KlStream) stream;
} else if (filetype == (KlO) KlK_tcp) { /* tcp socket stream */
return KlSocketMake(filename, KlK_tcp, error, direction,
buffered, blocking);
} else if (filetype == (KlO) KlK_udp) { /* udp socket stream */
return KlSocketMake(filename, KlK_udp, error, direction,
buffered, blocking);
} else if (filetype == (KlO) KlK_pipe) { /* a bidirectional pipe */
int pipe_fds[2]; /* opened in IO mode */
KlStream stream;
if (pipe(pipe_fds) < 0) {
KlOpenError(0, filename, KlK_io, 1);
}
stream = KlStreamMake(fdopen(pipe_fds[0], "r"), 3, filename->string);
stream->write_fd = fdopen(pipe_fds[1], "w");
stream->subtype = KlStreamProcessType;
/* non-buffered? */
if (KlFalseP(buffered)) {
setbuf(stream->write_fd, 0);
}
/* non-blocking? */
if (KlFalseP(blocking)) {
KlSetFILENoBlocking(stream->fd, 1, &(stream->blocking));
KlSetFILENoBlocking(stream->write_fd, 1, &(stream->blocking));
}
} else { /* default: unknown keyowrd error */
return (KlStream)
KlError3(KlE_INVALID_KEYWORD_VALUE, filetype, KlK_type,
KlListNullTerminated(KlOpenKV_filetype));
}
}
/* KlOpenError
*/
KlStream
KlOpenError(error, name, mode, reason)
KlO error;
KlString name;
KlKeyword mode;
char *reason; /* string or null or 1 for errno */
{
if (error) {
return (KlStream) KlSend_eval(error);
} else {
return (KlStream) KlError3(KlE_ERROR_OPENING_FILE, name, mode,
(reason == (char *) 1
? (KlO) KlErrnoGet(errno)
: (KlO) KlStringMake(reason ? reason : "")));
}
}
/* auxilliary function */
#ifdef SYSV
#define KlNDELAY O_NDELAY
#else
#define KlNDELAY FNDELAY
#endif
KlSetFILENoBlocking(fp, flag, klone_flag)
FILE *fp;
int flag;
char *klone_flag;
{
int file_mode;
fcntl(KlFp2Fd(fp), F_GETFL, &file_mode);
if (flag)
file_mode |= KlNDELAY; /* set non-blocking flag */
else
file_mode &= ~KlNDELAY; /* remove non-blocking flag */
fcntl(KlFp2Fd(fp), F_SETFL, file_mode);
*klone_flag = flag ? 0 : 1; /* set blocking flag to opposite */
}
/*****************************************************************************\
* KlStreamMode *
\*****************************************************************************/
/* stream-mode stream
* :writer t|()
* :blocking t|()
* :buffered t|() only buffered () does something
* (stream-mode [:writer flag]) lists modes as a plist
* (stream-mode :buffered ()) MUST be done before first read or write
*/
KlO
KlStreamMode(argc, argv)
int argc;
KlO *argv;
{
KlO writer, blocking, buffered;
KlStream stream;
FILE *fp;
char *flagp;
KlParseKeywords(argc, argv, 1);
writer = KlKeyVal(KlK_writer, NIL);
blocking = KlKeyVal(KlK_blocking, 0);
buffered = KlKeyVal(KlK_buffered, 0);
KlCheckUnvalidKeywords(argc, argv, 1);
stream = (KlStream) argv[0];
KlMustBeStream(stream, 0);
if ((stream->subtype & KlStreamFileType) && KlStreamNotClosed(stream)) {
if (KlTrueP(writer) && stream->write_fd) {
fp = stream->write_fd;
flagp = &(stream->blocking_write);
} else {
fp = stream->fd;
flagp = &(stream->blocking);
}
if (blocking) { /* set */
KlSetFILENoBlocking(fp, KlFalseP(blocking), flagp);
}
if (buffered && KlFalseP(buffered)) {
setbuf(fp, 0);
}
if (!blocking && !buffered) { /* get */
if (KlTrueP(writer) && stream->write_fd) {
return (KlO) KlListPairMake(KlK_blocking,
stream->blocking_write
? TRU : NIL);
} else {
return (KlO) KlListPairMake(KlK_blocking,
stream->blocking ? TRU : NIL);
}
}
}
return (KlO) stream;
}
/*****************************************************************************\
* KlFseek *
\*****************************************************************************/
/* KlFseek
* seeking into a file
* (file-position stream &optional offset from_where)
* from_where = 0,1,2 for start,current_pos,end of file
* returns t (success) () (failure)
* other values = ftell (default)
*/
KlO
KlFseek(argc, argv)
int argc;
KlO *argv;
{
KlStreamString stream;
int offset = 0;
int from_where = -1;
KlO result = TRU;
switch(argc) {
case 1:
break;
case 2:
KlMustBeNumber(argv[1], 1);
offset = ((KlNumber) argv[1])->number;
from_where = 0;
break;
case 3:
KlMustBeNumber(argv[1], 1);
KlMustBeNumber(argv[2], 2);
offset = ((KlNumber) argv[1])->number;
from_where = ((KlNumber) argv[2])->number;
break;
default:
return KlBadNumberOfArguments(argc);
}
stream = (KlStreamString) argv[0];
KlMustBeStream(stream, 0);
stream->parse_dirty = 1;
if (stream->subtype & KlStreamFileType) {
if (((unsigned int) from_where) > 2) {
return (KlO) KlNumberMake(ftell(((KlStream) stream)->fd));
} else {
if (fseek(((KlStream) stream)->fd, offset, from_where))
result = NIL; /* -1 = failure */
}
} else { /* string streams */
int len = KlModStringLength(stream->klstring);
int pos;
switch (from_where) {
case 0:
pos = offset;
break;
case 1:
pos = stream->cursor + offset;
break;
case 2:
pos = len + offset;
break;
default:
return (KlO) KlNumberMake(stream->cursor);
}
if (pos >= 0) {
if (pos >= stream->limit) {
if (KlHasTrait(stream->klstring, KlTrait_unreallocable)) {
return KlError(KlE_NO_APPEND, stream->klstring);
}
stream->limit = KlMallocChunkSize(pos + 1);
stream->klstring->string = (char *)
Realloc(stream->klstring->string, stream->limit);
}
stream->cursor = pos;
if (pos > len) { /* if past the end, fill with blanks */
bzero(stream->klstring->string+len, pos-len);
stream->klstring->string[pos] = '\0';
KlModStringSetLength(stream->klstring, pos);
}
} else
result = NIL;
}
return result;
}
/* printing streams
*/
KlO
KlStreamPrint(obj, stream)
KlStream obj;
KlStream stream;
{
KlSPrintf(stream, "{^ %s", KlTypeCName(obj->type));
KlSPrintf(stream, " 0x%x ", obj);
if (obj->subtype & KlStreamFileType) {
KlSPrintf(stream, "\"%s\"", obj->name);
if (KlStreamNotClosed(obj))
KlSPrintf(stream, " fd=%d", KlFp2Fd(obj->fd));
} else {
KlSend_print(KlA_String, stream);
}
KlSPrintf(stream, " %s}", KlStreamDirectionsText[obj->direction]);
return (KlO) obj;
}
/* closing streams
* (close stream [ :writer t|() ] )
* writer allows you to close only one direction of a bidirectional stream
* may not work on streams where the underlying fd is the same but fdopened
* via 2 different fps (sockets), it will generate a close error
*/
KlO
KlStreamClose(argc, argv)
int argc;
KlO *argv;
{
KlStream obj;
KlO writer;
int close_error = 0; /* keep flag */
KlParseKeywords(argc, argv, 1);
writer = KlKeyVal(KlK_writer, 0);
KlCheckUnvalidKeywords(argc, argv, 1);
obj = (KlStream) argv[0];
KlMustBeStream(obj, 0);
/* nothing is needed to be done for strings */
/* we do not send kill to the process */
if (obj->subtype & KlStreamFileType) {
if (obj->direction) {
signal(SIGPIPE, SIG_IGN);
if (writer && obj->direction == 3) { /* we close only one dir */
if (KlTrueP(writer)) { /* close output dir */
if (obj->write_fd) {
if (fclose(obj->write_fd))
close_error = 1;
obj->write_fd = 0;
}
obj->direction = 1;
} else { /* close input dir */
if (obj->write_fd) {
fclose(obj->fd);
obj->fd = obj->write_fd;
obj->write_fd = 0;
}
obj->direction = 2;
}
KlTrapSIGPIPE();
goto end;
} else {
int not_same_underlying_fd;
if (obj->direction == 3 && obj->write_fd && obj->fd &&
(KlFp2Fd(obj->fd) == KlFp2Fd(obj->write_fd))) {
not_same_underlying_fd = 0;
} else {
not_same_underlying_fd = 1;
}
/* close first output, we may have data to flush */
if (obj->write_fd) {
if (fclose(obj->write_fd)) {
close_error = 1;
}
obj->write_fd = 0;
}
/* then input, it doesnt matter if it was closed above */
if (fclose(obj->fd) && (obj->direction & 2)
&& not_same_underlying_fd) {
close_error = 1;
}
obj->fd = 0;
}
KlTrapSIGPIPE();
}
}
obj->direction = 0;
end:
if (close_error)
KlError2(KlE_STREAM_ERROR, KlA_write, obj);
return NIL;
}
/* freeing streams (closes files)
*/
KlO
KlStreamFree(obj)
KlStream obj;
{
if (obj->subtype == KlStreamStringType) { /* strings */
KlDecRef(((KlStreamString) obj)->klstring);
} else { /* file & processes */
KlStreamClose(1, &obj);
Free(obj->name);
}
Klyy_delete_buffer(obj->parse_state); /* can be passed a NULL ptr */
Free(obj);
return (KlO) obj;
}
/*ARGSUSED*/
KlResetStdout(old, dummy)
KlStream old;
KlO dummy;
{
KlStdout = old;
}
/*****************************************************************************\
* IO redirection *
\*****************************************************************************/
/* active values on:
* *standard-input* [497]
* *standard-output*
* *standard-error*
*/
KlO
KlStreamStdGet(stptr)
KlStream *stptr;
{
return (KlO) * stptr;
}
KlO
KlStreamStdSet(obj, stptr)
KlStream obj;
KlStream *stptr;
{
KlMustBeStream(obj, 0);
if (stptr == &KlStdin) {
KlStreamCanREAD(obj);
} else {
KlStreamCanWRITE(obj);
KlFlush(0);
}
KlDecRef(*stptr);
KlIncRef(*stptr = obj);
return (KlO) obj;
}
/*****************************************************************************\
* parsing stream *
\*****************************************************************************/
extern struct yy_buffer_state *Klyy_scan_bytes(); /* flex */
extern struct yy_buffer_state *Klyy_create_buffer(); /* flex */
/* to redirect parsing stream
* returns old stream (or 0 if not changed)
* it now relies heavily on flex mecanisms to do so
*/
KlStream
KlStdyyRedirect(stream)
KlStream stream;
{
if (stream != KlStdyy) { /* do nothing if same */
KlStream oldstream;
int unswitched = 1;
KlMustBeStream(stream, 0);
KlStreamCanREAD(stream);
/* init place to hold the flex parse state if necessary */
if (!stream->parse_state) {
if (stream->subtype == KlStreamStringType) {
/* note: this copies the data, since flex modifies its input */
int cursor = ((KlStreamString) stream)->cursor;
stream->parse_state = Klyy_scan_bytes(
((KlStreamString) stream)->klstring->string + cursor,
((KlStreamString) stream)->klstring->size - cursor);
unswitched = 0; /* this function switches */
} else {
stream->parse_state =
Klyy_create_buffer(stream->fd, Klyy_buf_size);
/* by default we refuse to use the flex bufferisation as it
interferes too much with fseek-ing. only load uses it */
Klyy_set_bufferized(stream->parse_state,
stream->parse_bufferized);
}
}
oldstream = KlStdyy;
oldstream->read_expr = KlReadExpr;
KlReadExpr = stream->read_expr;
KlDecRef(KlStdyy);
KlIncRef(KlStdyy = stream);
KlStdyy->parse_disabled = 0;
if (unswitched)
Klyy_switch_to_buffer(stream->parse_state); /* flex function */
return oldstream;
} else {
return stream;
}
}
/* init parse stream to stdin */
KlStdyyInit()
{
KlIncRef(KlStdyy = KlStdin);
KlStdyy->parse_state = Klyy_create_buffer(KlStdyy->fd, Klyy_buf_size);
Klyy_switch_to_buffer(KlStdyy->parse_state);
}
/* stream is dirty, clean it */
KlStdyyReset(stream)
KlStream stream;
{
if (stream->parse_state) { /* no need to RE-set if not set */
if (stream->subtype == KlStreamStringType) {
/* for strings, we brutally reset by deleting/recreating */
int cursor = ((KlStreamString) stream)->cursor;
Klyy_delete_buffer(stream->parse_state);
stream->parse_state = Klyy_scan_bytes(
((KlStreamString) stream)->klstring->string + cursor,
((KlStreamString) stream)->klstring->size - cursor);
} else {
/* for files, flex provides us with a more efficient method */
/* normally should be only necessary for bufferized streams) */
if (stream->parse_bufferized)
Klyy_flush_buffer(stream->parse_state);
}
}
stream->parse_dirty = 0; /* cleaned */
}
/* functions used to print where we are in the loaded file */
char *
KlIsReadingFile()
{
if (
KlStdyy &&
KlStdyy->subtype == KlStreamFileType &&
KlStdyy->name && *(KlStdyy->name) &&
KlStdyy->fd) {
return KlStdyy->name;
}
return 0;
}
/*
* KlRead: is now a macro
* reads an expression from the input (string or stream).
* returns this expression or NULL if EOF reached
* In case of syntax error, returns NIL
* the read expression is in the global variable KlReadExpr,
* if you need it. (this global is maintained for ref count purposes)
* You don't need to free it since it's done at the beginning of this
* routine.
* Beware that it could be overwritten by a subsequent call to KlEval
* or KlRead !
*/
static
KlReadKlAux(oldpos, oldstream)
char *oldpos;
KlStream oldstream;
{
((KlStreamString) KlStdyy)->cursor += (Klyy_bufptr() - oldpos);
KlStdyyRedirect(oldstream);
}
/* The klone-callable read function
* jumps to tag EOF on EOF
*/
KlO
KlReadKl(argc, argv)
int argc;
KlO *argv;
{
KlStream oldstream = KlStdyy;
KlO result = NIL;
if (argc) {
KlMustBeStream(argv[0], 0);
KlStreamCanREAD(((KlStream)argv[0]));
if (argc > 2)
return KlBadNumberOfArguments(argc);
oldstream = KlStdyyRedirect(argv[0]);
}
if (KlStdyy->parse_dirty) /* some seek happened meanwhile */
KlStdyyReset(KlStdyy);
if (KlStdyy == oldstream) { /* no need to redirect back */
Klyyparse();
} else {
if (KlStdyy->subtype == KlStreamStringType) {
/* we must increment by hand the cursor position for strings */
char *oldpos = Klyy_bufptr();
KlUnwindProtectStatement((Klyyparse(), result = KlReadExpr),
KlReadKlAux, oldpos, oldstream);
} else {
KlUnwindProtectStatement((Klyyparse(), result = KlReadExpr),
KlApplyUnary, KlStdyyRedirect, oldstream);
}
}
/* note that we couldnt use KlReadExpr directly as it was modified by the
* restoring KlStdyyRedirect to oldstream
*/
if (result)
return result;
else
if (argc >= 2)
return KlSend_eval(argv[1]);
else
KlThrow(KlA_EOF, NIL); /* EOF */
/* NOTREACHED */
}
/* KlDoReadAndEval
* Low-level function to parse and evaluate all exprs of current stdin
* does not perform any GC itself
*/
KlO
KlDoReadAndEval()
{
KlO result = NIL;
KlO PreviousExpr;
if (!KlRead()) goto end_empty;
PreviousExpr = KlReadExpr;
while (KlRead()) {
if (KlReadExpr == (KlO) KlA_equal && KlInfixAssigns) {
/* x = y, create assign */
if (!(KlRead())) /* x = EOF */
goto end;
PreviousExpr = (KlO) KlAssignMake(PreviousExpr, KlReadExpr);
} else { /* normal */
KlSend_eval(PreviousExpr);
PreviousExpr = KlReadExpr;
}
}
end:
result = KlSend_eval(PreviousExpr);
end_empty:
return result;
}
/* KlParseString
* parses a C string and returns expr. (with execute parameter 0)
* raw no-error-checking function to be used in C initialisations
*/
KlO
KlParseStringRaw(execute)
int execute; /* 0= only parse, 1= real/+eval loop */
{
KlO result = NIL;
if (execute) {
result = KlDoReadAndEval();
} else {
Klyyparse(), result = KlReadExpr ? KlReadExpr : NIL;
}
return result;
}
KlO
KlParseString(l, s, execute)
int l; /* length of string */
char *s;
int execute; /* 0= only parse, 1= real/+eval loop */
{
KlStream oldstream = 0;
KlO result;
oldstream = KlStdyyRedirect(KlStreamStringMake(KlStringPtrMake(l, s),
1));
KlUnwindProtectStatement(result = KlParseStringRaw(execute), KlApplyUnary,
KlStdyyRedirect, oldstream);
return result;
}
/*****************************************************************************\
* IO *
\*****************************************************************************/
/* flushing a stream
* 0 = stdout + stderr
*/
KlO
KlFlush(obj)
KlStream obj;
{
if (obj && KlTrueP(obj)) {
if (obj->type == KlStreamType
&& (obj->subtype & KlStreamFileType)) {
if (obj->direction & KlStreamOWRITE) {
if (fflush(KlStreamWriteFd(obj)))
KlError2(KlE_STREAM_ERROR, KlA_write, obj);
/* for streams in :io mode, we must also do a filepos op
* to avoid getting garbage from bufferisation
*/
if ((obj->direction & KlStreamOREAD)
&& !(obj->write_fd)) {
fseek(obj->fd, 0L, SEEK_CUR); /* noop to synchronise */
}
}
}
} else {
if (KlStdout->subtype & KlStreamFileType
&& KlStdout->direction & KlStreamOWRITE)
if (fflush(KlStreamWriteFd(KlStdout)))
KlError2(KlE_STREAM_ERROR, KlA_write, KlStdout);
if (KlStderr->subtype & KlStreamFileType
&& KlStderr->direction & KlStreamOWRITE)
if (fflush(KlStreamWriteFd(KlStderr)))
KlError2(KlE_STREAM_ERROR, KlA_write, KlStderr);
}
return NIL;
}
/***********************\
* C- callable functions *
\***********************/
/* prints a printf-formatted string */
KlSPrintf(stream, format, string)
KlStream stream;
char *format;
char *string;
{
KlStreamCanWRITE(stream);
if (stream->subtype == KlStreamStringType) {
char tmp[KlMAX_TEMP_STRING_SIZE];
sprintf(tmp, format, string);
KlSPuts(tmp, stream);
} else {
fprintf(KlStreamWriteFd(stream), format, string);
}
}
/* to print readably without enclosing double-quotes in KlPrintFormatAux */
#define PFPRINT(l, s, st) if(must_unstrip) \
KlSPuts(KlUnstripString(l, s), st); else KlSPutBytes(l, s, st);
static char *percent_string = "%";
/* print-format
* (print-format stream format arguments...)
* %NN are replaced by the printing of the N-th argument
* for 0 <= N
* (type of object can be printed also by %tN)
* %N can be printed readably by %rN
* %lN prints readably and quotes newlines
* % is printed by %%
* %ffunc-nameN applies func-name to argN and prints result
* %sN prints it in raw string mode ^Sstring^S
* if format is not a string it is applied to arguments and the result is
* used as format
*/
KlPrintFormatAux(stream, argc, argv)
KlStream stream;
int argc;
KlO *argv;
{
char *format, *p, *end;
int pos;
int print_with_type; /* 0= no, 1 = yes */
int print_readably; /* 0=as is, 1= no, 2 = readably */
int quote_newlines; /* 0= no, 1 = yes */
KlString klformat = (KlString) argv[1];
int prv = KlPrintReadably;
int qnl = KlQuoteNewlines;
int must_unstrip = (KlPrintReadably && !KlPrintAsRawStrings
&& !KlPrintFormatOldBehavior);
if (klformat->type != KlStringType) { /* if not a string, apply */
if (KlIsAnAtom(klformat) && KlIsAString(((KlAtom)klformat)->c_val)) {
klformat = (KlString) ((KlAtom)klformat)->c_val;
} else {
KlList call = KlListKl(argc - 1, argv + 1);
klformat = (KlString) KlApply(call);
KlMustBeString(klformat, 1);
}
}
format = klformat->string;
end = format + KlStringLength(klformat);
if (prv && !KlPrintFormatOldBehavior)
KlSPutc(KlPrintAsRawStrings ? 30 : 34, stream);
for (p = format; p < end; p++) {
if (*p == '%') { /* see a subst place */
KlO funcname = 0;
int option_char = 1;
int print_raw = 0;
PFPRINT(p - format, format, stream); /* print up to it */
print_with_type = 0;
print_readably = 0;
quote_newlines = 0;
do { /* interpret options */
switch (*(++p)) {
case 'r' : /* print-readably */
print_readably = 2;
break;
case 'n': /* not print-readably (normal) */
print_readably = 1;
break;
case 't': /* prints type */
print_with_type = 1;
break;
case 'l': /* readably & quote newlines */
quote_newlines = 1;
print_readably = 2;
break;
case 'f': /* apply a function */
{
char *start = ++p;
while (isalpha(*p) || strchr(":-_", *p)) {
p++;
}
funcname = (KlO) KlInternBytes(p - start, start);
p--;
}
break;
case 's' :
print_raw = 1;
break;
default: /* %%: prints second char */
option_char = 0;
}
} while (option_char);
if (isdigit(*p)) {
pos = (*p) - '0' + 2;
while (isdigit(*(p+1))) {
pos = (pos * 10) + (*(++p));
}
if (pos >= 2 && pos < argc) {
KlO arg = funcname ? KlApplyV(funcname, 1, argv[pos])
: argv[pos];
if (print_raw) {
if (!KlIsAString(arg))
arg = KlCoerce(arg, KlStringType);
KlSPutBytes(KlStringLength((KlString) arg),
((KlString) arg)->string, stream);
} else {
if (print_readably)
KlPrintReadably = print_readably - 1;
if (quote_newlines)
KlQuoteNewlines = 1;
if (print_with_type) {
KlSPuts(KlTypeCName(arg->type), stream);
} else {
KlSPrint(arg, stream);
}
if (print_readably)
KlPrintReadably = prv;
if (quote_newlines)
KlQuoteNewlines = qnl;
}
}
} else if (*p == '%') { /* %% = % */
PFPRINT(1, percent_string, stream);
} else if (*p == '\0') { /* % at end */
PFPRINT(1, percent_string, stream);
p--;
} else { /* %<any_char> = % */
PFPRINT(1, percent_string, stream);
PFPRINT(1, p, stream);
}
format = p+1; /* make the start next char */
}
}
PFPRINT(end - format, format, stream);
if (prv && !KlPrintFormatOldBehavior)
KlSPutc(KlPrintAsRawStrings ? 30 : 34, stream);
}
KlO
KlPrintFormat(argc, argv)
int argc;
KlO *argv;
{
KlStream stream;
KlNumberOfArgumentsCheck(argc < 1, argc);
/* decode the polymorph first argument */
if (KlIsAString(argv[0])
&& !KlIsASymbol(argv[0])) { /* stream arg can be omitted */
stream = KlStdout;
argc++;
argv--;
} else if (KlIsAStream(argv[0])) { /* normal case, stream */
stream = (KlStream) argv[0];
KlStreamCanWRITE(stream);
} else if ((argv[0] == (KlO) KlStringType) /* create new string stream */
|| (argv[0] == (KlO) KlA_String)) {
KlStreamString klstream = KlStreamStringMake(KlStringMake(0), 3);
KlPrintFormatAux(klstream, argc, argv);
return (KlO) klstream->klstring;
} else if (argv[0] == NIL) { /* () = stdout */
stream = KlStdout;
} else {
KlMustBeStream(argv[0], 0); /* give meaningful error mess */
}
if (argc > 1) /* argv[0] is the stream */
KlPrintFormatAux(stream, argc, argv);
return NIL;
}
/* KlSPutBytes
* the heart of printing in Klone. Nearly all output goes through this.
*/
KlSPutBytes(length, buffer, stream)
int length;
char *buffer;
KlStreamString stream;
{
if (stream->subtype == KlStreamStringType) {
if ((stream->cursor + length) >= stream->limit) { /* realloc */
if (KlHasTrait(stream->klstring, KlTrait_unreallocable)) {
return (int) KlError(KlE_NO_APPEND, stream->klstring);
}
stream->limit = KlMallocChunkSize(stream->cursor + length + 1);
stream->klstring->string = (char *)
Realloc(stream->klstring->string, stream->limit);
stream->klstring->string[stream->cursor + length] = '\0';
}
bcopy(buffer, stream->klstring->string + stream->cursor, length);
stream->cursor += length;
if (stream->cursor >= KlModStringLength(stream->klstring)) {
/* we extended the string, let's add a null byte for C compat */
KlModStringSetLength(stream->klstring, stream->cursor);
stream->klstring->string[stream->cursor] = '\0';
}
} else {
if (length !=
fwrite(buffer, 1, length, KlStreamWriteFd((KlStream) stream))) {
KlError2(KlE_STREAM_ERROR, KlA_write, stream); /* no space left */
}
}
}
/* KlSPuts
* prints a string. Mainly used from short C strings now that
* Klone strings are byte stings
*/
KlSPuts(string, stream)
char *string;
KlStreamString stream;
{
if (stream->subtype == KlStreamStringType) {
KlSPutBytes(strlen(string), string, stream);
} else {
if (EOF == fputs(string, (KlStreamWriteFd((KlStream) stream)))) {
/* error: no space left */
KlError2(KlE_STREAM_ERROR, KlA_write, stream);
}
}
}
/* reading a string
* returns pointer to static storage or 0 on EOF
* reads till \n or eof, do not returns final \n.
* mistakes NULL bytes in the input for EOF!, but this provides mucho speed!
*/
static int KlGets_tmpl;
static char *KlGets_tmp;
char *
KlGets(stream, lenptr)
KlStream stream;
int *lenptr; /* returns length of string */
{
int length;
if (stream->subtype == KlStreamStringType) { /* string */
KlStreamString klstream = (KlStreamString) stream;
char *start = klstream->klstring->string + klstream->cursor;
char *end = klstream->klstring->string +
KlStringLength( klstream->klstring);
char *p = start;
if (start == end) /* EOF */
return 0;
while (p < end && *p != '\n')
p++;
length = p - start;
if (length >= KlGets_tmpl) {
KlGets_tmpl = length;
KlGets_tmp = (char *) Realloc(KlGets_tmp, KlGets_tmpl + 1);
}
bcopy(start, KlGets_tmp, length);
KlGets_tmp[length] = '\0';
klstream->cursor = p - klstream->klstring->string +
((p < end) ? 1 : 0); /* skip newline, unless at EOF */
*lenptr = length;
return KlGets_tmp;
} else { /* file */
return KlFGets(stream->fd, lenptr);
}
}
/* KlFGets
* useful function to read an unlimited line (but terminates on '\0')
*/
char *
KlFGets(fd, lenptr)
FILE *fd;
int *lenptr;
{
char *p = KlGets_tmp;
int length;
KlGets_tmp[KlGets_tmpl - 2] = '\0'; /* marker overriden when more */
while (fgets(p, KlGets_tmpl - (p - KlGets_tmp), fd)) {
if (KlGets_tmp[KlGets_tmpl - 2]
&& KlGets_tmp[KlGets_tmpl - 2] != '\n') { /* more to read */
KlGets_tmpl += 1024;
#ifdef VOID_MALLOC
KlGets_tmp = (char *) Realloc(KlGets_tmp, KlGets_tmpl);
#else
KlGets_tmp = (char *) Realloc(KlGets_tmp, KlGets_tmpl);
#endif /* VOID_MALLOC */
p = KlGets_tmp + KlGets_tmpl - 1 - 1024;
KlGets_tmp[KlGets_tmpl - 2] = '\0';
} else { /* done */
goto done;
}
}
if (p == KlGets_tmp) /* EOF */
return 0;
done:
/* trim last newline if present and return */
length = strlen(KlGets_tmp);
if (length > 0 && KlGets_tmp[length - 1] == '\n')
KlGets_tmp[--length] = '\0';
else
KlGets_tmp[length] = '\0';
*lenptr = length;
return KlGets_tmp;
}
/* reading a char
* retunrs EOF on eof
*/
int
KlGetc(stream)
KlStream stream;
{
if (stream->subtype == KlStreamStringType) {
KlStreamString klstream = (KlStreamString) stream;
char *p = klstream->klstring->string + klstream->cursor;
if (klstream->cursor < KlStringLength(klstream->klstring)) {
klstream->cursor++;
return *p;
} else {
return EOF;
}
} else {
return getc(stream->fd);
}
}
/*************************\
* klone-callable functions *
\*************************/
KlResetKlPrintLevel(a, b)
KlO a, b;
{
KlPrintLevel = -1;
}
/*
* ? (or print) simply print value of an object
*/
/* klone-level one, handling *print-level*
*/
KlO
KlPrintNary(argc, argv)
int argc;
KlO argv[];
{
int i;
if (KlPrintLevel >= 0) { /* we are inside a print */
for (i = 0; i < argc; i++)
KlSend_print(argv[i], KlStdout);
} else { /* we start printing, init p-l */
KlPrintLevel = 0;
KlUnwindProtectStatement
(for (i = 0; i < argc; i++) KlSend_print(argv[i], KlStdout),
KlResetKlPrintLevel, 0, 0);
}
KlFlush(0);
return argc ? argv[argc - 1] : NIL;
}
/* low-level one, do not handle *print-level*
*/
KlO
KlWrite(argc, argv)
int argc;
KlO *argv;
{
switch (argc) {
case 1:
KlSend_print(argv[0], KlStdout);
break;
case 2:
KlMustBeStream(argv[1], 1);
KlStreamCanWRITE(((KlStream) argv[1]));
KlSend_print(argv[0], argv[1]);
break;
default:
return KlBadNumberOfArguments(argc);
}
return argv[0];
}
/* klone-level one, handling *print-level*
*/
KlO
KlWriteKl(argc, argv)
int argc;
KlO *argv;
{
if (KlPrintLevel >= 0) { /* we are inside a print */
return KlWrite(argc, argv);
} else { /* we start printing, init p-l */
KlO result;
KlPrintLevel = 0;
KlUnwindProtect(KlWrite(argc, argv), result, KlResetKlPrintLevel,
0, 0);
return result;
}
}
KlO
KlWriteChar(argc, argv)
int argc;
KlO *argv;
{
KlStream stream;
switch (argc) {
case 1:
stream = KlStdout;
break;
case 2:
stream = (KlStream) argv[1];
KlMustBeStream(stream, 1);
KlStreamCanWRITE(stream);
break;
default:
return KlBadNumberOfArguments(argc);
}
if (KlIsAString(argv[0])) {
KlSPuts(((KlString) argv[0])->string, stream);
} else {
KlMustBeNumber(argv[0], 0);
KlSPutc(((KlNumber) argv[0])->number, stream);
}
return argv[0];
}
KlO
KlWriteLine(argc, argv)
int argc;
KlString *argv;
{
KlStream stream;
switch (argc) {
case 1:
stream = KlStdout;
break;
case 2:
stream = (KlStream) argv[1];
KlMustBeStream(stream, 1);
KlStreamCanWRITE(stream);
break;
default:
return KlBadNumberOfArguments(argc);
}
KlMustBeString(argv[0], 0);
KlSPutBytes(KlStringLength(argv[0]), argv[0]->string, stream);
KlSPutc('\n', stream);
return (KlO) argv[0];
}
/* read functions callable from klone */
KlO
KlReadChar(argc, argv)
int argc;
KlStream *argv;
{
KlStream stream;
int c;
switch (argc) {
case 0:
stream = KlStdin;
break;
case 1: case 2:
stream = argv[0];
KlMustBeStream(stream, 0);
KlStreamCanREAD(stream);
break;
default:
return KlBadNumberOfArguments(argc);
}
c = KlGetc(stream);
if (c == EOF) {
if (argc == 2)
return KlSend_eval(argv[1]);
else
KlThrow(KlA_EOF, NIL);
/* NOTREACHED */
} else {
return (KlO) KlNumberMake(c);
}
}
KlO
KlReadLine(argc, argv)
int argc;
KlStream *argv;
{
KlStream stream;
char *s;
int len;
switch (argc) {
case 0:
stream = KlStdin;
break;
case 1: case 2:
stream = argv[0];
KlMustBeStream(stream, 0);
KlStreamCanREAD(stream);
break;
default:
return KlBadNumberOfArguments(argc);
}
if (s = KlGets(stream, &len)) {
return (KlO) KlStringMakeFromBytes(len, s);
} else {
if (argc == 2)
return KlSend_eval(argv[1]);
else
KlThrow(KlA_EOF, NIL);
/* NOTREACHED */
}
}
/*****************************************************************************\
* readwrite of N chars at a time, on possibly non-blocking streams *
\*****************************************************************************/
/* (read-chars N [stream])
*/
KlO
KlReadChars(argc, argv)
int argc;
KlStream *argv;
{
KlStream stream = KlStdin;
int n = -1;
switch (argc) {
case 2:
stream = argv[1];
KlMustBeStream(stream, 1);
KlStreamCanREAD(stream);
/* no break intentional */
case 1:
if (KlTrueP(argv[0])) {
KlMustBeNumber(argv[0], 0);
n = ((KlNumber) argv[0])->number;
}
/* no break intentional */
case 0:
break;
default:
return KlBadNumberOfArguments(argc);
}
if (stream->subtype == KlStreamStringType) { /* string */
int nread;
if (n >= 0) { /* part */
nread = Min(n, (int)
KlStringLength(((KlStreamString) stream)->klstring)
- ((KlStreamString) stream)->cursor);
} else { /* up to end */
nread = (int) KlStringLength(((KlStreamString) stream)->klstring)
- ((KlStreamString) stream)->cursor;
}
((KlStreamString) stream)->cursor += nread;
return (KlO) KlStringMakeFromBytes
(nread, ((KlStreamString) stream)->klstring->string
+ ((KlStreamString) stream)->cursor - nread);
} else { /* file */
KlString s;
clearerr(stream->fd); /* reset eof indicator */
if (n >= 0) { /* part */
char *buffer = (char *) Malloc(n + 1);
int nread = fread(buffer, 1, n, stream->fd);
buffer[nread] = '\0';
s = KlStringMakeNoCopy(nread, buffer);
/* no Free of buffer, will be done by GC of s */
} else { /* whole: gobble up everything */
s = (KlString) KlStreamToStringCoerce(KlStringType, stream);
}
if (!KlModStringLength(s) /* no input? maybe eof? */
&& feof(stream->fd)) {
KlThrow(KlA_EOF, NIL);
}
return (KlO) s;
}
}
/* (write-chars string N [stream] [offset])
*/
KlO
KlWriteChars(argc, argv)
int argc;
KlStream *argv;
{
KlStream stream = KlStdout;
KlString s;
int n = -1;
int offset = 0;
switch (argc) {
case 4:
KlMustBeNumber(argv[3], 3);
offset = ((KlNumber) argv[3])->number;
case 3:
stream = argv[2];
KlMustBeStream(argv[2], 2);
KlStreamCanWRITE(stream);
/* no break intentional */
case 2:
if (KlTrueP(argv[1])) {
KlMustBeNumber(argv[1], 1);
n = ((KlNumber) argv[1])->number;
}
/* no break intentional */
case 1:
break;
default:
return KlBadNumberOfArguments(argc);
}
s = (KlString) argv[0];
KlMustBeString(argv[0], 0);
if (n >= 0)
n = Min(n, (int) KlStringLength(s) - offset);
else
n = KlStringLength(s) - offset;
if (stream->subtype == KlStreamStringType) { /* no problemo */
KlSPutBytes(n, s->string + offset, stream);
} else { /* file */
n = fwrite(s->string + offset, 1, n,
KlStreamWriteFd((KlStream) stream));
}
return (KlO) KlNumberMake(n);
}
/**************************************************************************\
* select *
\**************************************************************************/
/* (select [:input] streams... [:output streams...] [:error streams]
* [:timeout milliseconds-or-nil])
* works with buffering and strings!
* returns () (no stream were ready, and timeout expired or signal received)
* or a list of 3 lists being the lists of streams ready for input, output,
* and having an exceptional condition pending.
* streams can be streams or lists of streams which are expanded.
* any stream can be () and is then ignored
* :input keyword is implicitely delared at the start
* :timeout 0 means non-blocking, nonexisting or () means blocks indefinitely
* (default)
* keywords can appear in any order
* select is made of :input (read), :output (write) or :error (execptional
* condition pending)
* before going to the UNIX select() call observed streams are examined. If
* one of them satisfies one of the following criteria, KlStreamSelect returns
* immediately with the matching streams without actually calling select(2)
* [1] buffered input file stream having some characters still in the input
* buffer in the FILE structure
* [2] string streams in read or write mode (always ready)
* WARNING: (select) blocks indefinitely!
* WARNING: select on a file at EOF returns true!. to test if a file is a EOF,
* if select is true but read-non-blocking returns 0, then EOF is
* here.
*/
/* descriptor used to prepare the arguments lists to select(2) */
struct KlStreamList {
int mode; /* read, write or read&write (error) */
fd_set set; /* to be passed to select */
KlList list; /* list of selected streams */
KlList ready_list; /* results: streams with pending IO */
};
KlO
KlStreamSelect(argc, argv)
int argc;
KlStream *argv;
{
int nfds = 0, n, i, res;
struct KlStreamList arglists[3], *arglistp = &(arglists[0]);
struct timeval timeout, *timeoutp = 0; /* blocking */
KlStream *arg = argv, *last = argv+argc;
for (i = 0; i < 3; i++) { /* init the 3 KlStreamLists */
FD_ZERO(&(arglists[i].set));
arglists[i].list = KlListNMake(0);
arglists[i].ready_list = KlListNMake(0);
arglists[i].mode = i+1; /* hack */
}
while (arg < last) { /* parses args */
if (KlIsAKeyword(*arg)) { /* keyword change cur. KlStreamList */
if (KlK_timeout == (KlKeyword) *arg) {
if (++arg < last && KlTrueP(*arg)) {
KlMustBeNumber(*arg, arg - argv);
timeout.tv_sec = ((KlNumber)*arg)->number / 1000;
timeout.tv_usec = (((KlNumber)*arg)->number % 1000) * 1000;
#ifdef AMIGA
if (((KlNumber)*arg)->number == 0)
timeout.tv_usec = 1; /* bug in amiga select? */
#endif /* AMIGA */
timeoutp = &timeout;
} else {
timeoutp = 0; /* () ==> no timeout, blocking */
}
} else if (KlK_input == (KlKeyword) *arg) {
arglistp = arglists;
} else if (KlK_output == (KlKeyword) *arg) {
arglistp = arglists + 1;
} else if (KlK_error == (KlKeyword) *arg) {
arglistp = arglists + 2;
} else {
KlKeyword KlSelectKeywords[5], *p = KlSelectKeywords;
*p++ = KlK_input;
*p++ = KlK_output;
*p++ = KlK_error;
*p++ = KlK_timeout;
*p++ = 0;
KlError2(KlE_INVALID_KEYWORD, *arg,
KlListNullTerminated(KlSelectKeywords));
}
} else if (KlIsAList(*arg)) { /* expand lists of streams */
for (i = 0; i < ((KlList) (*arg))->size; i++) {
if ((n = KlStreamSelectArgAdd
(((KlList)(*arg))->list[i], arg-argv, arglistp))
> nfds)
nfds = n;
}
} else { /* simple case of a streams */
if ((n = KlStreamSelectArgAdd(*arg, arg-argv, arglistp)) > nfds)
nfds = n;
}
arg++;
}
for (i = 0; i < 3; i++) /* returns if something in buffers */
if (arglists[i].ready_list->size)
goto end;
/* do the UNIX call */
for (;;) {
KlLastSignal = 0;
res = select(nfds, &(arglists[0].set), &(arglists[1].set),
&(arglists[2].set), timeoutp);
if (res > 0) {
/* OK, constructs the returned triplet */
KlStream obj;
for (i = 0; i < arglists[0].list->size; i++) {
if (KlIsAFileStream(obj = (KlStream) arglists[0].list->list[i])
&& FD_ISSET(KlFp2Fd(obj->fd), &(arglists[0].set)))
KlListAppend(arglists[0].ready_list, obj);
}
for (i = 0; i < arglists[1].list->size; i++) {
if (KlIsAFileStream(obj = (KlStream) arglists[1].list->list[i])
&& FD_ISSET(KlFp2Fd(KlStreamWriteFd(obj)),
&(arglists[1].set)))
KlListAppend(arglists[1].ready_list, obj);
}
for (i = 0; i < arglists[2].list->size; i++) {
if (KlIsAFileStream(obj = (KlStream) arglists[2].list->list[i])
&& (FD_ISSET(KlFp2Fd(obj->fd), &(arglists[2].set))
|| (obj->write_fd
&& FD_ISSET(KlFp2Fd(obj->write_fd),
&(arglists[2].set)))))
KlListAppend(arglists[2].ready_list, obj);
}
goto end;
} else if (res < 0) { /* error (signal such as SIGCHLD) */
if (errno != EINTR || KlLastSignal != KlSIGCHLD)
return NIL; /* SIGCHLD ? continue : return NIL */
} else { /* none pending */
return NIL;
}
}
end:
{ /* actual building of returned list */
KlList reslist = KlListNMake(3);
for (i = 0; i < 3; i++)
KlIncRef(reslist->list[i] = (KlO) arglists[i].ready_list);
return (KlO) reslist;
}
}
/* main parsing (by accumulation) used by KlStreamSelect
* accumulates arg into a KlStreamList struct
* checks if a stream is structurally ready (chars in buffer) and already
* puts it in ready_list field
* return fd+1 if correct file descriptor monitored or 0
*/
int
KlStreamSelectArgAdd(obj, pos, slistp)
KlStream obj;
int pos;
struct KlStreamList *slistp;
{
int fd, res = 0;
if (KlFalseP(obj)) /* ignore () */
return 0;
KlMustBeStream(obj, pos);
if (!(obj->direction & (slistp->mode)))
KlError2(KlE_STREAM_ERROR,
(slistp->mode == KlStreamOWRITE) ? KlA_write : KlA_read, obj);
KlListAppend(slistp->list, obj);
if (KlIsAFileStream(obj)) { /* file */
if ((obj->direction) & KlStreamOWRITE & (slistp->mode)) {
fd = KlFp2Fd(KlStreamWriteFd(obj));
FD_SET(fd, &(slistp->set));
res = Max(res, fd+1);
}
if ((obj->direction) & KlStreamOREAD & (slistp->mode)) {
fd = KlFp2Fd(obj->fd);
FD_SET(fd, &(slistp->set));
res = Max(res, fd+1);
}
if (slistp->mode == KlStreamOREAD /* if chars in buffer, ready */
&& READ_DATA_PENDING(obj->fd))
KlListAppend(slistp->ready_list, obj);
} else { /* string */
/* strings always ready to write */
KlListAppend(slistp->ready_list, obj);
}
return res;
}
/*****************************************************************************\
* coercions *
\*****************************************************************************/
/* string->stream
* open a string stream
*/
/*ARGSUSED*/
KlO
KlStringToStreamCoerce(totype, obj)
KlType totype;
KlString obj;
{
return (KlO) KlStreamStringMake(KlStringCopy(obj), 3);
}
/*ARGSUSED*/
KlO
KlStreamToStringCoerce(totype, stream)
KlType totype;
KlStream stream;
{
struct stat buf;
if (stream->subtype == KlStreamStringType) { /* string */
return (KlO) ((KlStreamString)stream)->klstring;
} else {
KlStreamCanREAD(stream);
if (stream->subtype == KlStreamFileType /* leave out sockets, pipes */
&& !fstat(KlFp2Fd(stream->fd), &buf)
&& (buf.st_mode & S_IFREG)) { /* regular file of known length */
int size;
KlString str = KlStringNMake(buf.st_size);
size = fread(str->string, 1, buf.st_size, stream->fd);
*(str->string + size) = '\0';
KlModStringSetLength(str, size);
return (KlO) str;
} else { /* stream of unknown length */
KlString str = KlStringNMake(1019);
int offset = 0;
int nitems;
int to_get = 1019;
int bufsize = 1024;
for (;;) {
nitems = fread(str->string + offset, 1, to_get, stream->fd);
if (!nitems) {
if (!stream->blocking || feof(stream->fd)) {
break; /* EOF, ok end loop */
} else {
/* error. wait a bit before retry */
struct timeval timeout;
timeout.tv_sec = 0;
timeout.tv_usec = 100; /* wait 1/10th of a second */
select(0, 0, 0, 0, &timeout);
}
}
offset += nitems;
if (offset > bufsize / 2) {
bufsize *= 2;
str->string = (char *) Realloc(str->string, bufsize - 4);
}
to_get = bufsize - offset -4 -1;
}
*(str->string + offset) = '\0';
KlModStringSetLength(str, offset);
return (KlO) str;
}
}
}
/*****************************************************************************\
* TYPE INIT *
\*****************************************************************************/
KlStreamInit()
{
int i;
KlDeclareType(&KlStreamType, "Stream", sizeof(struct _KlStream));
KlDeclareMethod1(KlStreamType, KlSelPrint, KlStreamPrint);
KlDeclareMethod1(KlStreamType, KlSelFree, KlStreamFree);
KlDeclareSubr(KlOpen, "open", NARY);
KlDeclareSubr(KlStreamClose, "close", NARY);
KlA_write = (KlAtom) KlDeclareSubr(KlWrite, "write", NARY);
KlDeclareSubr(KlWriteLine, "write-line", NARY);
KlDeclareSubr(KlWriteChar, "write-char", NARY);
KlA_read = (KlAtom) KlDeclareSubr(KlReadKl, "read", NARY);
KlDeclareSubr(KlReadLine, "read-line", NARY);
KlDeclareSubr(KlReadChar, "read-char", NARY);
KlDeclareSubr(KlFlush, "flush", 1);
KlDeclareSubr(KlPrintFormat, "print-format", NARY);
KlDeclareSubr(KlFseek, "file-position", NARY);
KlDeclareSubr(KlStreamMode, "stream-mode", NARY);
KlDeclareSubr(KlReadChars, "read-chars", NARY);
KlDeclareSubr(KlWriteChars, "write-chars", NARY);
KlDeclareSubr(KlStreamSelect, "select", NARY);
KlIncRef(KlStdin = KlStreamMake(stdin, 1, "stdin"));
KlIncRef(KlStdout = KlStreamMake(stdout, 2, "stdout"));
KlIncRef(KlStderr = KlStreamMake(stderr, 2, "stderr"));
KlA_StdinOrig = KlConstantMake("*standard-input-orig*", KlStdin);
KlA_StdoutOrig = KlConstantMake("*standard-output-orig*", KlStdout);
KlA_StderrOrig = KlConstantMake("*standard-error-orig*", KlStderr);
KlA_stdin = KlActiveMake("*standard-input*",
KlStreamStdGet, KlStreamStdSet, &KlStdin);
KlA_stdout = KlActiveMake("*standard-output*",
KlStreamStdGet, KlStreamStdSet, &KlStdout);
KlA_stderr = KlActiveMake("*standard-error*",
KlStreamStdGet, KlStreamStdSet, &KlStderr);
KlStdyy = 0;
KlIncRef(KlStdpool = KlStreamStringMake(KlStringMake(" "), 1));
KlDeclareCoerce(KlStringType, KlStreamType, KlStringToStreamCoerce);
KlDeclareCoerce(KlStreamType, KlStringType, KlStreamToStringCoerce);
/* keyword lists */
KlOpenKV_if_exists = (KlKeyword *) Malloc(KLSO * 5); i = 0;
KlOpenKV_if_exists[i++] = KlK_supersede;
KlOpenKV_if_exists[i++] = KlK_error;
KlOpenKV_if_exists[i++] = KlK_append;
KlOpenKV_if_exists[i++] = KlK_overwrite;
KlOpenKV_if_exists[i++] = 0;
KlOpenKV_direction = (KlKeyword *) Malloc(KLSO * 4); i = 0;
KlOpenKV_direction[i++] = KlK_input;
KlOpenKV_direction[i++] = KlK_io;
KlOpenKV_direction[i++] = KlK_output;
KlOpenKV_direction[i++] = 0;
KlOpenKV_filetype = (KlKeyword *) Malloc(KLSO * 6); i = 0;
KlOpenKV_filetype[i++] = KlK_file;
KlOpenKV_filetype[i++] = KlK_string;
KlOpenKV_filetype[i++] = KlK_tcp;
KlOpenKV_filetype[i++] = KlK_udp;
KlOpenKV_filetype[i++] = KlK_pipe;
KlOpenKV_filetype[i++] = 0;
/* initializes stdin */
#ifdef AMIGA
Klyyin = stdin;
#endif /* AMIGA */
KlGets_tmpl = 1020;
KlGets_tmp = (char *) Malloc(KlGets_tmpl);
}
syntax highlighted by Code2HTML, v. 0.9.1