/*
* tclXlgets.c
*
* Extended Tcl lgets command.
*-----------------------------------------------------------------------------
* Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans.
*
* Permission to use, copy, modify, and distribute this software and its
* documentation for any purpose and without fee is hereby granted, provided
* that the above copyright notice appear in all copies. Karl Lehenbauer and
* Mark Diekhans make no representations about the suitability of this
* software for any purpose. It is provided "as is" without express or
* implied warranty.
*-----------------------------------------------------------------------------
* $Id: tclXlgets.c,v 8.8 1999/03/31 06:37:45 markd Exp $
*-----------------------------------------------------------------------------
*/
/*
*-----------------------------------------------------------------------------
* Note: The list parsing code is from Tcl distribution file tclUtil.c,
* procedure TclFindElement:
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
*-----------------------------------------------------------------------------
*/
#include "tclExtdInt.h"
/*
* State for current list being read.
*/
typedef struct {
Tcl_Channel channel; /* Channel to read from */
Tcl_DString buffer; /* Buffer for line being read */
int lineIdx; /* Index of next line to read. */
} ReadData;
/*
* Prototypes of internal functions.
*/
static int
ReadListLine (Tcl_Interp *interp,
ReadData *dataPtr);
static int
ReadListInit (Tcl_Interp *interp,
Tcl_Channel channel,
ReadData *dataPtr);
static int
ReadListElement (Tcl_Interp *interp,
ReadData *dataPtr,
Tcl_Obj *elemObjPtr);
static int
TclX_LgetsObjCmd (ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]);
/*-----------------------------------------------------------------------------
* ReadLineList --
*
* Read a list line from a channel.
*
* Paramaters:
* o interp - Errors are returned in result.
* o dataPtr - Data for list read.
* Returns:
* o TCL_OK if read succeeded..
* o TCL_BREAK if EOF without reading any data.
* o TCL_ERROR if an error occured, with error message in interp.
*-----------------------------------------------------------------------------
*/
static int
ReadListLine (Tcl_Interp *interp,
ReadData *dataPtr)
{
/*
* Read the first line of the list.
*/
if (Tcl_Gets (dataPtr->channel, &dataPtr->buffer) < 0) {
if (Tcl_Eof (dataPtr->channel)) {
/*
* If not first read, then we have failed in the middle of a list.
*/
if (dataPtr->lineIdx > 0) {
TclX_AppendObjResult (interp, "EOF in list element",
(char *) NULL);
return TCL_ERROR;
}
return TCL_BREAK; /* EOF with no data */
}
TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL);
return TCL_ERROR;
}
/*
* If data was read, but the read terminate with an EOF rather than a
* newline, its an error.
*/
if (Tcl_Eof (dataPtr->channel)) {
TclX_AppendObjResult (interp,
"EOF encountered before newline while reading ",
"list from channel", (char *) NULL);
return TCL_ERROR;
}
/*
* Add back in the newline.
*/
Tcl_DStringAppend (&dataPtr->buffer, "\n", 1);
return TCL_OK;
}
/*-----------------------------------------------------------------------------
* ReadListInit --
*
* Initialize for reading list elements from a file.
*
* Paramaters:
* o interp - Errors are returned in result.
* o channel - The channel to read from.
* o dataPtr - Data for list read.
* Returns:
* o TCL_OK if read to read.
* o TCL_BREAK if EOF without reading any data.
* o TCL_ERROR if an error occured, with error message in interp.
*-----------------------------------------------------------------------------
*/
static int
ReadListInit (Tcl_Interp *interp,
Tcl_Channel channel,
ReadData *dataPtr)
{
int rstat;
char *p, *limit;
dataPtr->channel = channel;
Tcl_DStringInit (&dataPtr->buffer);
dataPtr->lineIdx = 0;
rstat = ReadListLine (interp, dataPtr);
if (rstat != TCL_OK)
return rstat;
/*
* Advance to the first non-whitespace.
*/
p = Tcl_DStringValue (&dataPtr->buffer);
limit = p + Tcl_DStringLength (&dataPtr->buffer);
while ((p < limit) && (isspace(UCHAR(*p)))) {
p++;
}
dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer);
return TCL_OK;
}
/*-----------------------------------------------------------------------------
* ReadListElement --
*
* Read the next element of the list. If the end of the string is reached
* while still in the list element, read another line.
*
* Paramaters:
* o interp - Errors are returned in result.
* o dataPtr - Data for list read. As initialized by ReadListInit.
* o elemObjPtr - An object to copy the list element to.
* Returns:
* o TCL_OK if an element was read.
* o TCL_BREAK if the end of the list was reached.
* o TCL_ERROR if an error occured.
* Notes:
* Code is a modified version of UCB procedure tclUtil.c:TclFindElement
*-----------------------------------------------------------------------------
*/
static int
ReadListElement (Tcl_Interp *interp,
ReadData *dataPtr,
Tcl_Obj *elemObjPtr)
{
register char *p;
char *cpStart; /* Points to next byte to copy. */
char *limit; /* Points just after list's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
int numChars;
char *p2;
int rstat, cpIdx;
p = Tcl_DStringValue (&dataPtr->buffer) + dataPtr->lineIdx;
limit = Tcl_DStringValue (&dataPtr->buffer) +
Tcl_DStringLength (&dataPtr->buffer);
/*
* If we are at the end of the string, there are no more elements.
*/
if (p == limit) { /* no element found */
return TCL_BREAK;
}
/*
* Check for an opening brace or quote. We treat embedded NULLs in the
* list as bytes belonging to a list element.
*/
if (*p == '{') {
openBraces = 1;
p++;
} else if (*p == '"') {
inQuotes = 1;
p++;
}
cpStart = p;
/*
* Find element's end (a space, close brace, or the end of the string).
*/
while (1) {
switch (*p) {
/*
* Open brace: don't treat specially unless the element is in
* braces. In this case, keep a nesting count.
*/
case '{':
if (openBraces != 0) {
openBraces++;
}
break;
/*
* Close brace: if element is in braces, keep nesting count and
* quit when the last close brace is seen.
*/
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
p++;
if ((p >= limit) || isspace(UCHAR(*p))) {
goto done;
}
/*
* Garbage after the closing brace; return an error.
*/
if (interp != NULL) {
char buf[100];
p2 = p;
while ((p2 < limit) && (!isspace(UCHAR(*p2)))
&& (p2 < p+20)) {
p2++;
}
sprintf(buf,
"list element in braces followed by \"%.*s\" instead of space",
(int) (p2-p), p);
Tcl_ResetResult (interp);
TclX_AppendObjResult (interp, buf, (char *) NULL);
}
return TCL_ERROR;
}
break;
/*
* Backslash: skip over everything up to the end of the
* backslash sequence. Copy the character to the output obj
* and reset the location of the rest of the string to copy.
* If in braces, include backslash and character as-is, otherwise
* drop it.
*/
case '\\': {
char bsChar;
bsChar = Tcl_Backslash(p, &numChars);
if (openBraces > 0) {
p += (numChars - 1); /* Advanced again at end of loop */
} else {
Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
Tcl_AppendToObj (elemObjPtr, &bsChar, 1);
p += (numChars - 1);
cpStart = p + 1; /* already stored character */
}
break;
}
/*
* Space: ignore if element is in braces or quotes; otherwise
* terminate element.
*/
case ' ':
case '\f':
case '\n':
case '\r':
case '\t':
case '\v':
if ((openBraces == 0) && !inQuotes) {
Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
goto done;
}
break;
/*
* Double-quote: if element is in quotes then terminate it.
*/
case '"':
if (inQuotes) {
Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
p++;
if ((p >= limit) || isspace(UCHAR(*p))) {
goto done;
}
/*
* Garbage after the closing quote; return an error.
*/
if (interp != NULL) {
char buf[100];
p2 = p;
while ((p2 < limit) && (!isspace(UCHAR(*p2)))
&& (p2 < p+20)) {
p2++;
}
sprintf(buf,
"list element in quotes followed by \"%.*s\" %s",
(int) (p2-p), p, "instead of space");
Tcl_ResetResult (interp);
TclX_AppendObjResult (interp, buf, (char *) NULL);
}
return TCL_ERROR;
}
break;
/*
* Zero byte.
*/
case 0: {
/*
* If we are not at the end of the string, this is just
* binary data in the list..
*/
if (p != limit)
break; /* Byte of zero */
if ((openBraces == 0) && (inQuotes == 0)) {
Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
goto done;
}
/*
* Need new line. Buffer might be realloc-ed, so recalculate
* pointers. Note we set `p' to one back, since we don't want
* the p++ below to miss the next character.
*/
dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer);
cpIdx = cpStart - Tcl_DStringValue (&dataPtr->buffer);
rstat = ReadListLine (interp, dataPtr);
if (rstat != TCL_OK)
return rstat;
p = Tcl_DStringValue (&dataPtr->buffer) + dataPtr->lineIdx - 1;
limit = Tcl_DStringValue (&dataPtr->buffer) +
Tcl_DStringLength (&dataPtr->buffer);
cpStart = Tcl_DStringValue (&dataPtr->buffer) + cpIdx;
}
}
p++;
}
done:
while ((p < limit) && (isspace(UCHAR(*p)))) {
p++;
}
dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer);
return TCL_OK;
}
/*-----------------------------------------------------------------------------
* Tcl_LgetsObjCmd --
*
* Implements the `lgets' Tcl command:
* lgets fileId ?varName?
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*-----------------------------------------------------------------------------
*/
static int
TclX_LgetsObjCmd (ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Channel channel;
ReadData readData;
int rstat, optValue;
Tcl_Obj *elemObj, *dataObj;
if ((objc < 2) || (objc > 3)) {
return TclX_WrongArgs (interp, objv [0], "fileId ?varName?");
}
channel = TclX_GetOpenChannelObj (interp, objv [1], TCL_READABLE);
if (channel == NULL)
return TCL_ERROR;
/*
* If the channel is non-blocking, its an error, we don't support it
* yet.
* FIX: Make callback driven for non-blocking.
*/
if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BLOCKING,
&optValue) != TCL_OK)
return TCL_ERROR;
if (optValue == TCLX_MODE_NONBLOCKING) {
TclX_AppendObjResult (interp, "channel is non-blocking; not ",
"currently supported by the lgets command",
(char *) NULL);
return TCL_ERROR;
}
/*
* Read the list, parsing off each element until the list is read.
* More lines are read if newlines are encountered in the middle of
* a list.
*/
rstat = ReadListInit (interp, channel, &readData);
dataObj = Tcl_NewListObj (0, NULL);
Tcl_IncrRefCount (dataObj);
while (rstat == TCL_OK) {
elemObj = Tcl_NewStringObj ("", 0);
rstat = ReadListElement (interp, &readData, elemObj);
if (rstat == TCL_OK) {
Tcl_ListObjAppendElement (NULL, dataObj, elemObj);
} else {
Tcl_DecrRefCount (elemObj);
}
}
if (rstat == TCL_ERROR)
goto errorExit;
/*
* Return the string as a result or in a variable.
*/
if (objc == 2) {
Tcl_SetObjResult (interp, dataObj);
} else {
int resultLen;
if (Tcl_ObjSetVar2(interp, objv[2], NULL, dataObj,
TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) {
goto errorExit;
}
if (Tcl_Eof (channel) || Tcl_InputBlocked (channel)) {
resultLen = -1;
} else {
/* Adjust length for extra newlines that are inserted */
resultLen = Tcl_DStringLength (&readData.buffer) - 1;
}
Tcl_SetIntObj (Tcl_GetObjResult (interp), resultLen);
}
Tcl_DecrRefCount (dataObj);
Tcl_DStringFree (&readData.buffer);
return TCL_OK;
errorExit:
/*
* If a variable is supplied, return whatever data we have in buffer
* that has not been processed. The last bit of data is save as
* the last element. This is mostly good for debugging.
*/
if (objc > 2) {
Tcl_Obj *saveResult;
int len = Tcl_DStringLength (&readData.buffer) - readData.lineIdx;
if (len > 0) {
Tcl_ListObjAppendElement (
NULL, dataObj,
Tcl_NewStringObj (Tcl_DStringValue (&readData.buffer),
len));
}
saveResult = Tcl_GetObjResult (interp);
Tcl_IncrRefCount (saveResult);
/*
* Save data in variable, if an error occures, let it be reported
* instead of original error.
* FIX: Need functions to save/restore error state.
*/
if (Tcl_ObjSetVar2(interp, objv[2], NULL, dataObj,
TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) != NULL) {
Tcl_SetObjResult (interp, saveResult); /* Restore old message */
}
Tcl_DecrRefCount (saveResult);
}
Tcl_DecrRefCount (dataObj);
Tcl_DStringFree (&readData.buffer);
return TCL_ERROR;
}
/*-----------------------------------------------------------------------------
* TclX_LgetsInit --
* Initialize the lgets command.
*-----------------------------------------------------------------------------
*/
void
TclX_LgetsInit (Tcl_Interp *interp)
{
Tcl_CreateObjCommand (interp,
"lgets",
TclX_LgetsObjCmd,
(ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL);
}
/* vim: set ts=8 sw=4 sts=4 et : */