1/*
2 * tclXbsearch.c
3 *
4 * Extended Tcl binary file search 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: tclXbsearch.c,v 1.3 2005/04/26 20:01:33 hobbs Exp $
16 *-----------------------------------------------------------------------------
17 */
18
19#include "tclExtdInt.h"
20
21/*
22 * Control block used to pass data used by the binary search routines.
23 */
24typedef struct binSearchCB_t {
25    Tcl_Interp   *interp;         /* Pointer to the interpreter.             */
26    char         *key;            /* The key to search for.                  */
27
28    Tcl_Channel   channel;        /* I/O channel.                            */
29    Tcl_DString   lineBuf;        /* Dynamic buffer to hold a line of file.  */
30    off_t         lastRecOffset;  /* Offset of last record read.             */
31    int           cmpResult;      /* -1, 0 or 1 result of string compare.    */
32    char         *tclProc;        /* Name of Tcl comparsion proc, or NULL.   */
33    } binSearchCB_t;
34
35/*
36 * Prototypes of internal functions.
37 */
38static int
39StandardKeyCompare _ANSI_ARGS_((char *key,
40                                char *line));
41
42static int
43TclProcKeyCompare _ANSI_ARGS_((binSearchCB_t *searchCBPtr));
44
45static int
46ReadAndCompare _ANSI_ARGS_((off_t          fileOffset,
47                            binSearchCB_t *searchCBPtr));
48
49static int
50BinSearch _ANSI_ARGS_((binSearchCB_t *searchCBPtr));
51
52static int
53TclX_BsearchObjCmd _ANSI_ARGS_((ClientData clientData,
54                                Tcl_Interp *interp,
55                                int objc,
56                                Tcl_Obj *CONST objv[]));
57
58/*-----------------------------------------------------------------------------
59 *
60 * StandardKeyCompare --
61 *    Standard comparison routine for BinSearch, compares the key to the
62 *    first white-space seperated field in the line.
63 *
64 * Parameters:
65 *   o key (I) - The key to search for.
66 *   o line (I) - The line to compare the key to.
67 *
68 * Results:
69 *   o < 0 if key < line-key
70 *   o = 0 if key == line-key
71 *   o > 0 if key > line-key.
72 *-----------------------------------------------------------------------------
73 */
74static int
75StandardKeyCompare (key, line)
76    char *key;
77    char *line;
78{
79    int  cmpResult, fieldLen;
80    char saveChar;
81
82    fieldLen = strcspn (line, " \t\r\n\v\f");
83
84    saveChar = line [fieldLen];
85    line [fieldLen] = 0;
86    cmpResult = strcmp (key, line);
87    line [fieldLen] = saveChar;
88
89    return cmpResult;
90}
91
92/*-----------------------------------------------------------------------------
93 * TclProcKeyCompare --
94 *    Comparison routine for BinSearch that runs a Tcl procedure to,
95 *    compare the key to a line from the file.
96 *
97 * Parameters:
98 *   o searchCBPtr (I/O) - The search control block, the line should be in
99 *     lineBuf, the comparsion result is returned in cmpResult.
100 *
101 * Results:
102 *   TCL_OK or TCL_ERROR.
103 *-----------------------------------------------------------------------------
104 */
105static int
106TclProcKeyCompare (searchCBPtr)
107    binSearchCB_t *searchCBPtr;
108{
109    CONST84 char *cmdArgv [3];
110    char *command, *oldResult;
111    int   result;
112
113    cmdArgv [0] = searchCBPtr->tclProc;
114    cmdArgv [1] = searchCBPtr->key;
115    cmdArgv [2] = searchCBPtr->lineBuf.string;
116    command = Tcl_Merge (3, cmdArgv);
117
118    result = Tcl_Eval (searchCBPtr->interp, command);
119
120    ckfree (command);
121    if (result == TCL_ERROR)
122        return TCL_ERROR;
123
124    if (Tcl_GetIntFromObj (searchCBPtr->interp,
125                           Tcl_GetObjResult (searchCBPtr->interp),
126                           &searchCBPtr->cmpResult) != TCL_OK) {
127        oldResult = Tcl_GetStringFromObj (
128            Tcl_GetObjResult (searchCBPtr->interp), NULL);
129        oldResult = ckstrdup (oldResult);
130
131        Tcl_ResetResult (searchCBPtr->interp);
132        TclX_AppendObjResult (searchCBPtr->interp, "invalid integer \"",
133                              oldResult, "\" returned from compare proc \"",
134                              searchCBPtr->tclProc, "\"", (char *) NULL);
135        ckfree (oldResult);
136        return TCL_ERROR;
137    }
138    Tcl_ResetResult (searchCBPtr->interp);
139    return TCL_OK;
140}
141
142/*-----------------------------------------------------------------------------
143 * ReadAndCompare --
144 *    Search for the next line in the file starting at the specified
145 *    offset.  Read the line into the dynamic buffer and compare it to
146 *    the key using the specified comparison method.  The start of the
147 *    last line read is saved in the control block, and if the start of
148 *    the same line is found in the search, then it will not be recompared.
149 *    This is needed since the search algorithm has to hit the same line
150 *    a couple of times before failing, due to the fact that the records are
151 *    not fixed length.
152 *
153 * Parameters:
154 *   o fileOffset (I) - The offset of the next byte of the search, not
155 *     necessarly the start of a record.
156 *   o searchCBPtr (I/O) - The search control block, the comparsion result
157 *     is returned in cmpResult.  If the EOF is hit, a less-than result is
158 *     returned.
159 *
160 * Results:
161 *   TCL_OK or TCL_ERROR.
162 *-----------------------------------------------------------------------------
163 */
164static int
165ReadAndCompare (fileOffset, searchCBPtr)
166    off_t          fileOffset;
167    binSearchCB_t *searchCBPtr;
168{
169    if (Tcl_Seek (searchCBPtr->channel, fileOffset, SEEK_SET) < 0)
170        goto posixError;
171
172    /*
173     * Go to beginning of next line by reading the remainder of the current
174     * one.
175     */
176    if (fileOffset != 0) {
177        if (Tcl_Gets (searchCBPtr->channel, &searchCBPtr->lineBuf) < 0) {
178            if (Tcl_Eof (searchCBPtr->channel) ||
179                Tcl_InputBlocked (searchCBPtr->channel)) {
180                TclX_AppendObjResult (searchCBPtr->interp,
181                                    "bsearch got unexpected EOF on \"",
182                                    Tcl_GetChannelName (searchCBPtr->channel),
183                                     "\"", (char *) NULL);
184                return TCL_ERROR;
185            }
186            goto posixError;
187        }
188    }
189    fileOffset = (off_t) Tcl_Tell (searchCBPtr->channel);  /* Offset of next line */
190
191    /*
192     * If this is the same line as before, then just leave the comparison
193     * result unchanged.
194     */
195    if (fileOffset == searchCBPtr->lastRecOffset)
196        return TCL_OK;
197
198    searchCBPtr->lastRecOffset = fileOffset;
199
200    Tcl_DStringSetLength (&searchCBPtr->lineBuf, 0);
201
202    /*
203     * Read the line. Only compare if EOF was not hit, otherwise, treat as if
204     * we went above the key we are looking for.
205     */
206    if (Tcl_Gets (searchCBPtr->channel, &searchCBPtr->lineBuf) < 0) {
207        if (Tcl_Eof (searchCBPtr->channel) ||
208            Tcl_InputBlocked (searchCBPtr->channel)) {
209            searchCBPtr->cmpResult = -1;
210            return TCL_OK;
211        }
212        goto posixError;
213    }
214
215    /*
216     * Compare the line.
217     */
218    if (searchCBPtr->tclProc == NULL) {
219        searchCBPtr->cmpResult =
220            StandardKeyCompare (searchCBPtr->key,
221                                searchCBPtr->lineBuf.string);
222    } else {
223        if (TclProcKeyCompare (searchCBPtr) != TCL_OK)
224            return TCL_ERROR;
225    }
226
227    return TCL_OK;
228
229  posixError:
230   TclX_AppendObjResult (searchCBPtr->interp,
231                        Tcl_GetChannelName (searchCBPtr->channel), ": ",
232                        Tcl_PosixError (searchCBPtr->interp), (char *) NULL);
233   return TCL_ERROR;
234}
235
236/*-----------------------------------------------------------------------------
237 * BinSearch --
238 *      Binary search a sorted ASCII file.
239 *
240 * Parameters:
241 *   o searchCBPtr (I/O) - The search control block, if the line is found,
242 *     it is returned in lineBuf.
243 * Results:
244 *     TCL_OK - If the key was found.
245 *     TCL_BREAK - If it was not found.
246 *     TCL_ERROR - If there was an error.
247 *
248 * based on getpath.c from smail 2.5 (9/15/87)
249 *
250 *-----------------------------------------------------------------------------
251 */
252static int
253BinSearch (searchCBPtr)
254    binSearchCB_t *searchCBPtr;
255{
256    off_t middle, high, low;
257
258    low = 0;
259    if (TclXOSGetFileSize (searchCBPtr->channel, &high) != TCL_OK)
260        goto posixError;
261
262    /*
263     * "Binary search routines are never written right the first time around."
264     * - Robert G. Sheldon.
265     */
266
267    while (TRUE) {
268        middle = (high + low + 1) / 2;
269
270        if (ReadAndCompare (middle, searchCBPtr) != TCL_OK)
271            return TCL_ERROR;
272
273        if (searchCBPtr->cmpResult == 0)
274            return TCL_OK;     /* Found   */
275
276        if (low >= middle)
277            return TCL_BREAK;  /* Failure */
278
279        /*
280         * Close window.
281         */
282        if (searchCBPtr->cmpResult > 0) {
283            low = middle;
284        } else {
285            high = middle - 1;
286        }
287    }
288
289  posixError:
290   TclX_AppendObjResult (searchCBPtr->interp,
291                         Tcl_GetChannelName (searchCBPtr->channel), ": ",
292                         Tcl_PosixError (searchCBPtr->interp), (char *) NULL);
293   return TCL_ERROR;
294}
295
296/*-----------------------------------------------------------------------------
297 * TclX_BsearchObjCmd --
298 *     Implements the TCL bsearch command:
299 *        bsearch filehandle key ?retvar?
300 *-----------------------------------------------------------------------------
301 */
302static int
303TclX_BsearchObjCmd (clientData, interp, objc, objv)
304    ClientData   clientData;
305    Tcl_Interp  *interp;
306    int          objc;
307    Tcl_Obj     *CONST objv[];
308{
309    int status;
310    binSearchCB_t searchCB;
311
312    if ((objc < 3) || (objc > 5)) {
313        TclX_WrongArgs (interp, objv [0],
314                        "handle key ?retvar? ?compare_proc?");
315        return TCL_ERROR;
316    }
317
318    searchCB.channel = TclX_GetOpenChannelObj (interp,
319                                               objv [1],
320                                               TCL_READABLE);
321    if (searchCB.channel == NULL)
322        return TCL_ERROR;
323
324    searchCB.interp = interp;
325    searchCB.key = Tcl_GetStringFromObj (objv [2], NULL);
326    searchCB.lastRecOffset = -1;
327    searchCB.tclProc = (objc == 5) ? Tcl_GetStringFromObj (objv [4], NULL) :
328        NULL;
329
330    Tcl_DStringInit (&searchCB.lineBuf);
331
332    status = BinSearch (&searchCB);
333    if (status == TCL_ERROR) {
334        Tcl_DStringFree (&searchCB.lineBuf);
335        return TCL_ERROR;
336    }
337
338    if (status == TCL_BREAK) {
339        if ((objc >= 4) && !TclX_IsNullObj (objv [3]))
340            Tcl_SetBooleanObj (Tcl_GetObjResult (interp), FALSE);
341        goto okExit;
342    }
343
344    if ((objc == 3) || TclX_IsNullObj (objv [3])) {
345        Tcl_SetStringObj (Tcl_GetObjResult (interp),
346                          Tcl_DStringValue (&searchCB.lineBuf),
347                          -1);
348    } else {
349        Tcl_Obj *valPtr;
350
351        valPtr = Tcl_NewStringObj (Tcl_DStringValue (&searchCB.lineBuf),
352                                   -1);
353        if (Tcl_ObjSetVar2(interp, objv[3], NULL, valPtr,
354                           TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) {
355            Tcl_DecrRefCount (valPtr);
356            goto errorExit;
357        }
358        Tcl_SetBooleanObj (Tcl_GetObjResult (interp), TRUE);
359    }
360
361  okExit:
362    Tcl_DStringFree (&searchCB.lineBuf);
363    return TCL_OK;
364
365  errorExit:
366    Tcl_DStringFree (&searchCB.lineBuf);
367    return TCL_OK;
368}
369
370/*-----------------------------------------------------------------------------
371 * TclX_BsearchInit --
372 *     Initialize the bsearch command.
373 *-----------------------------------------------------------------------------
374 */
375void
376TclX_BsearchInit (interp)
377    Tcl_Interp *interp;
378{
379    Tcl_CreateObjCommand (interp,
380                          "bsearch",
381                          TclX_BsearchObjCmd,
382                          (ClientData) NULL,
383                          (Tcl_CmdDeleteProc*) NULL);
384}
385