1/*
2 * tclXlgets.c
3 *
4 * Extended Tcl lgets command.
5 *-----------------------------------------------------------------------------
6 * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans.
7 *
8 * Permission to use, copy, modify, and distribute this software and its
9 * documentation for any purpose and without fee is hereby granted, provided
10 * that the above copyright notice appear in all copies.  Karl Lehenbauer and
11 * Mark Diekhans make no representations about the suitability of this
12 * software for any purpose.  It is provided "as is" without express or
13 * implied warranty.
14 *-----------------------------------------------------------------------------
15 * $Id: tclXlgets.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $
16 *-----------------------------------------------------------------------------
17 */
18/*
19 *-----------------------------------------------------------------------------
20 * Note: The list parsing code is from Tcl distribution file tclUtil.c,
21 * procedure TclFindElement:
22 * Copyright (c) 1987-1993 The Regents of the University of California.
23 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
24 *-----------------------------------------------------------------------------
25 */
26
27#include "tclExtdInt.h"
28
29/*
30 * State for current list being read.
31 */
32typedef struct {
33    Tcl_Channel channel;   /* Channel to read from */
34    Tcl_DString buffer;    /* Buffer for line being read */
35    int lineIdx;           /* Index of next line to read. */
36} ReadData;
37
38
39/*
40 * Prototypes of internal functions.
41 */
42static int
43ReadListLine _ANSI_ARGS_((Tcl_Interp  *interp,
44                          ReadData    *dataPtr));
45
46static int
47ReadListInit _ANSI_ARGS_((Tcl_Interp  *interp,
48                          Tcl_Channel  channel,
49                          ReadData    *dataPtr));
50
51static int
52ReadListElement _ANSI_ARGS_((Tcl_Interp  *interp,
53                             ReadData    *dataPtr,
54                             Tcl_Obj     *elemObjPtr));
55
56static int
57TclX_LgetsObjCmd _ANSI_ARGS_((ClientData  clientData,
58                             Tcl_Interp  *interp,
59                             int          objc,
60                             Tcl_Obj     *CONST objv[]));
61
62
63/*-----------------------------------------------------------------------------
64 * ReadLineList --
65 *
66 *   Read a list line from a channel.
67 *
68 * Paramaters:
69 *   o interp - Errors are returned in result.
70 *   o dataPtr - Data for list read.
71 * Returns:
72 *   o TCL_OK if read succeeded..
73 *   o TCL_BREAK if EOF without reading any data.
74 *   o TCL_ERROR if an error occured, with error message in interp.
75 *-----------------------------------------------------------------------------
76 */
77static int
78ReadListLine (interp, dataPtr)
79    Tcl_Interp  *interp;
80    ReadData    *dataPtr;
81{
82    /*
83     * Read the first line of the list.
84     */
85    if (Tcl_Gets (dataPtr->channel, &dataPtr->buffer) < 0) {
86        if (Tcl_Eof (dataPtr->channel)) {
87            /*
88             * If not first read, then we have failed in the middle of a list.
89             */
90            if (dataPtr->lineIdx > 0) {
91                TclX_AppendObjResult (interp, "EOF in list element",
92                                      (char *) NULL);
93                return TCL_ERROR;
94            }
95            return TCL_BREAK;  /* EOF with no data */
96        }
97        TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL);
98        return TCL_ERROR;
99    }
100
101    /*
102     * If data was read, but the read terminate with an EOF rather than a
103     * newline, its an error.
104     */
105    if (Tcl_Eof (dataPtr->channel)) {
106        TclX_AppendObjResult (interp,
107                              "EOF encountered before newline while reading ",
108                              "list from channel", (char *) NULL);
109        return TCL_ERROR;
110    }
111
112    /*
113     * Add back in the newline.
114     */
115    Tcl_DStringAppend (&dataPtr->buffer, "\n", 1);
116    return TCL_OK;
117}
118
119
120/*-----------------------------------------------------------------------------
121 * ReadListInit --
122 *
123 *    Initialize for reading list elements from a file.
124 *
125 * Paramaters:
126 *   o interp - Errors are returned in result.
127 *   o channel - The channel to read from.
128 *   o dataPtr - Data for list read.
129 * Returns:
130 *   o TCL_OK if read to read.
131 *   o TCL_BREAK if EOF without reading any data.
132 *   o TCL_ERROR if an error occured, with error message in interp.
133 *-----------------------------------------------------------------------------
134 */
135static int
136ReadListInit (interp, channel, dataPtr)
137    Tcl_Interp  *interp;
138    Tcl_Channel  channel;
139    ReadData    *dataPtr;
140{
141    int rstat;
142    char *p, *limit;
143
144    dataPtr->channel = channel;
145    Tcl_DStringInit (&dataPtr->buffer);
146    dataPtr->lineIdx = 0;
147
148    rstat = ReadListLine (interp, dataPtr);
149    if (rstat != TCL_OK)
150        return rstat;
151
152    /*
153     * Advance to the first non-whitespace.
154     */
155    p =  Tcl_DStringValue (&dataPtr->buffer);
156    limit = p + Tcl_DStringLength (&dataPtr->buffer);
157    while ((p < limit) && (isspace(UCHAR(*p)))) {
158        p++;
159    }
160    dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer);
161    return TCL_OK;
162}
163
164
165/*-----------------------------------------------------------------------------
166 * ReadListElement --
167 *
168 *    Read the next element of the list.  If the end of the string is reached
169 * while still in the list element, read another line.
170 *
171 * Paramaters:
172 *   o interp - Errors are returned in result.
173 *   o dataPtr - Data for list read.  As initialized by ReadListInit.
174 *   o elemObjPtr - An object to copy the list element to.
175 * Returns:
176 *   o TCL_OK if an element was read.
177 *   o TCL_BREAK if the end of the list was reached.
178 *   o TCL_ERROR if an error occured.
179 * Notes:
180 *   Code is a modified version of UCB procedure tclUtil.c:TclFindElement
181 *-----------------------------------------------------------------------------
182 */
183static int
184ReadListElement (interp, dataPtr, elemObjPtr)
185    Tcl_Interp  *interp;
186    ReadData    *dataPtr;
187    Tcl_Obj     *elemObjPtr;
188{
189    register char *p;
190    char *cpStart;		/* Points to next byte to copy. */
191    char *limit;		/* Points just after list's last byte. */
192    int openBraces = 0;		/* Brace nesting level during parse. */
193    int inQuotes = 0;
194    int numChars;
195    char *p2;
196    int rstat, cpIdx;
197
198    p = Tcl_DStringValue (&dataPtr->buffer) + dataPtr->lineIdx;
199    limit = Tcl_DStringValue (&dataPtr->buffer) +
200        Tcl_DStringLength (&dataPtr->buffer);
201
202    /*
203     * If we are at the end of the string, there are no more elements.
204     */
205    if (p == limit) {		/* no element found */
206        return TCL_BREAK;
207    }
208
209    /*
210     * Check for an opening brace or quote. We treat embedded NULLs in the
211     * list as bytes belonging to a list element.
212     */
213
214    if (*p == '{') {
215	openBraces = 1;
216	p++;
217    } else if (*p == '"') {
218	inQuotes = 1;
219	p++;
220    }
221    cpStart = p;
222
223    /*
224     * Find element's end (a space, close brace, or the end of the string).
225     */
226
227    while (1) {
228	switch (*p) {
229
230	    /*
231	     * Open brace: don't treat specially unless the element is in
232	     * braces. In this case, keep a nesting count.
233	     */
234
235	    case '{':
236		if (openBraces != 0) {
237		    openBraces++;
238		}
239		break;
240
241	    /*
242	     * Close brace: if element is in braces, keep nesting count and
243	     * quit when the last close brace is seen.
244	     */
245
246	    case '}':
247		if (openBraces > 1) {
248		    openBraces--;
249		} else if (openBraces == 1) {
250                    Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
251		    p++;
252		    if ((p >= limit) || isspace(UCHAR(*p))) {
253			goto done;
254		    }
255
256		    /*
257		     * Garbage after the closing brace; return an error.
258		     */
259
260		    if (interp != NULL) {
261			char buf[100];
262
263			p2 = p;
264			while ((p2 < limit) && (!isspace(UCHAR(*p2)))
265			        && (p2 < p+20)) {
266			    p2++;
267			}
268			sprintf(buf,
269				"list element in braces followed by \"%.*s\" instead of space",
270				(int) (p2-p), p);
271                        Tcl_ResetResult (interp);
272                        TclX_AppendObjResult (interp, buf, (char *) NULL);
273		    }
274		    return TCL_ERROR;
275		}
276		break;
277
278	    /*
279	     * Backslash:  skip over everything up to the end of the
280	     * backslash sequence.  Copy the character to the output obj
281             * and reset the location of the rest of the string to copy.
282             * If in braces, include backslash and character as-is, otherwise
283             * drop it.
284	     */
285
286	    case '\\': {
287		char bsChar;
288
289                bsChar = Tcl_Backslash(p, &numChars);
290                if (openBraces > 0) {
291                    p += (numChars - 1);  /* Advanced again at end of loop */
292                } else {
293                    Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
294                    Tcl_AppendToObj (elemObjPtr, &bsChar, 1);
295                    p += (numChars - 1);
296                    cpStart = p + 1;  /* already stored character */
297                }
298		break;
299	    }
300
301	    /*
302	     * Space: ignore if element is in braces or quotes; otherwise
303	     * terminate element.
304	     */
305
306	    case ' ':
307	    case '\f':
308	    case '\n':
309	    case '\r':
310	    case '\t':
311	    case '\v':
312		if ((openBraces == 0) && !inQuotes) {
313                    Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
314		    goto done;
315		}
316		break;
317
318	    /*
319	     * Double-quote: if element is in quotes then terminate it.
320	     */
321
322	    case '"':
323		if (inQuotes) {
324                    Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
325		    p++;
326		    if ((p >= limit) || isspace(UCHAR(*p))) {
327			goto done;
328		    }
329
330		    /*
331		     * Garbage after the closing quote; return an error.
332		     */
333
334		    if (interp != NULL) {
335			char buf[100];
336
337			p2 = p;
338			while ((p2 < limit) && (!isspace(UCHAR(*p2)))
339				 && (p2 < p+20)) {
340			    p2++;
341			}
342			sprintf(buf,
343				"list element in quotes followed by \"%.*s\" %s",
344				(int) (p2-p), p, "instead of space");
345                        Tcl_ResetResult (interp);
346                        TclX_AppendObjResult (interp, buf, (char *) NULL);
347		    }
348		    return TCL_ERROR;
349		}
350		break;
351
352	    /*
353	     * Zero byte.
354	     */
355
356	    case 0: {
357                /*
358                 * If we are not at the end of the string, this is just
359                 * binary data in the list..
360                 */
361                if (p != limit)
362                    break;  /* Byte of zero */
363
364                if ((openBraces == 0) && (inQuotes == 0)) {
365                    Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart));
366                    goto done;
367                }
368
369                /*
370                 * Need new line.  Buffer might be realloc-ed, so recalculate
371                 * pointers.  Note we set `p' to one back, since we don't want
372                 * the p++ below to miss the next character.
373                 */
374                dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer);
375                cpIdx = cpStart - Tcl_DStringValue (&dataPtr->buffer);
376
377                rstat = ReadListLine (interp, dataPtr);
378                if (rstat != TCL_OK)
379                    return rstat;
380
381                p = Tcl_DStringValue (&dataPtr->buffer) + dataPtr->lineIdx - 1;
382                limit = Tcl_DStringValue (&dataPtr->buffer) +
383                    Tcl_DStringLength (&dataPtr->buffer);
384                cpStart = Tcl_DStringValue (&dataPtr->buffer) + cpIdx;
385            }
386        }
387	p++;
388    }
389
390    done:
391    while ((p < limit) && (isspace(UCHAR(*p)))) {
392	p++;
393    }
394    dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer);
395    return TCL_OK;
396}
397
398/*-----------------------------------------------------------------------------
399 * Tcl_LgetsObjCmd --
400 *
401 * Implements the `lgets' Tcl command:
402 *    lgets fileId ?varName?
403 *
404 * Results:
405 *      A standard Tcl result.
406 *
407 * Side effects:
408 *      See the user documentation.
409 *-----------------------------------------------------------------------------
410 */
411static int
412TclX_LgetsObjCmd (clientData, interp, objc, objv)
413    ClientData   clientData;
414    Tcl_Interp  *interp;
415    int          objc;
416    Tcl_Obj    *CONST objv[];
417{
418    Tcl_Channel channel;
419    ReadData readData;
420    int rstat, optValue;
421    Tcl_Obj *elemObj, *dataObj;
422
423    if ((objc < 2) || (objc > 3)) {
424        return TclX_WrongArgs (interp, objv [0], "fileId ?varName?");
425    }
426
427    channel = TclX_GetOpenChannelObj (interp, objv [1], TCL_READABLE);
428    if (channel == NULL)
429        return TCL_ERROR;
430
431    /*
432     * If the channel is non-blocking, its an error, we don't support it
433     * yet.
434     * FIX: Make callback driven for non-blocking.
435     */
436    if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BLOCKING,
437                               &optValue) != TCL_OK)
438        return TCL_ERROR;
439    if (optValue == TCLX_MODE_NONBLOCKING) {
440        TclX_AppendObjResult (interp, "channel is non-blocking; not ",
441                              "currently supported by the lgets command",
442                              (char *) NULL);
443        return TCL_ERROR;
444    }
445
446    /*
447     * Read the list, parsing off each element until the list is read.
448     * More lines are read if newlines are encountered in the middle of
449     * a list.
450     */
451    rstat = ReadListInit (interp, channel, &readData);
452
453    dataObj = Tcl_NewListObj (0, NULL);
454    Tcl_IncrRefCount (dataObj);
455
456    while (rstat == TCL_OK) {
457        elemObj = Tcl_NewStringObj ("", 0);
458        rstat = ReadListElement (interp, &readData, elemObj);
459        if (rstat == TCL_OK) {
460            Tcl_ListObjAppendElement (NULL, dataObj, elemObj);
461        } else {
462            Tcl_DecrRefCount (elemObj);
463        }
464    }
465    if (rstat == TCL_ERROR)
466        goto errorExit;
467
468    /*
469     * Return the string as a result or in a variable.
470     */
471    if (objc == 2) {
472        Tcl_SetObjResult (interp, dataObj);
473    } else {
474        int resultLen;
475
476        if (Tcl_ObjSetVar2(interp, objv[2], NULL, dataObj,
477                           TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) {
478            goto errorExit;
479        }
480
481        if (Tcl_Eof (channel) || Tcl_InputBlocked (channel)) {
482            resultLen = -1;
483        } else {
484            /* Adjust length for extra newlines that are inserted */
485            resultLen = Tcl_DStringLength (&readData.buffer) - 1;
486        }
487        Tcl_SetIntObj (Tcl_GetObjResult (interp), resultLen);
488    }
489    Tcl_DecrRefCount (dataObj);
490    Tcl_DStringFree (&readData.buffer);
491    return TCL_OK;
492
493  errorExit:
494    /*
495     * If a variable is supplied, return whatever data we have in buffer
496     * that has not been processed.  The last bit of data is save as
497     * the last element.  This is mostly good for debugging.
498     */
499    if (objc > 2) {
500        Tcl_Obj *saveResult;
501        int len = Tcl_DStringLength (&readData.buffer) - readData.lineIdx;
502
503        if (len > 0) {
504            Tcl_ListObjAppendElement (
505                NULL, dataObj,
506                Tcl_NewStringObj (Tcl_DStringValue (&readData.buffer),
507                                  len));
508        }
509
510        saveResult = Tcl_GetObjResult (interp);
511        Tcl_IncrRefCount (saveResult);
512
513        /*
514         * Save data in variable, if an error occures, let it be reported
515         * instead of original error.
516         * FIX: Need functions to save/restore error state.
517         */
518        if (Tcl_ObjSetVar2(interp, objv[2], NULL, dataObj,
519                           TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) != NULL) {
520            Tcl_SetObjResult (interp, saveResult);  /* Restore old message */
521        }
522        Tcl_DecrRefCount (saveResult);
523    }
524
525    Tcl_DecrRefCount (dataObj);
526    Tcl_DStringFree (&readData.buffer);
527
528    return TCL_ERROR;
529}
530
531
532/*-----------------------------------------------------------------------------
533 * TclX_LgetsInit --
534 *     Initialize the lgets command.
535 *-----------------------------------------------------------------------------
536 */
537void
538TclX_LgetsInit (interp)
539    Tcl_Interp *interp;
540{
541    Tcl_CreateObjCommand (interp,
542                          "lgets",
543                          TclX_LgetsObjCmd,
544                          (ClientData) NULL,
545                          (Tcl_CmdDeleteProc*) NULL);
546}
547
548