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