source: trunk/base/src/registry2.0/util.c @ 64269

Last change on this file since 64269 was 64269, checked in by jmr@…, 11 years ago

fix reg2 deactivate

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 10.8 KB
Line 
1/*
2 * util.c
3 * $Id: util.c 64269 2010-02-28 02:45:55Z jmr@macports.org $
4 *
5 * Copyright (c) 2007 Chris Pickel <sfiera@macports.org>
6 * All rights reserved.
7 *
8 * Redistribution and use in source and binary forms, with or without
9 * modification, are permitted provided that the following conditions
10 * are met:
11 * 1. Redistributions of source code must retain the above copyright
12 *    notice, this list of conditions and the following disclaimer.
13 * 2. Redistributions in binary form must reproduce the above copyright
14 *    notice, this list of conditions and the following disclaimer in the
15 *    documentation and/or other materials provided with the distribution.
16 *
17 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
18 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20 * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
22 * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
23 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26 * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 */
28
29#if HAVE_CONFIG_H
30#include <config.h>
31#endif
32
33#include <string.h>
34#include <stdlib.h>
35#include <tcl.h>
36
37#include "util.h"
38#include "entryobj.h"
39
40/**
41 * Generates a unique proc name starting with prefix.
42 *
43 * This function loops through the integers trying to find a name
44 * "<prefix><int>" such that no command with that name exists within the given
45 * Tcl interp context. This behavior is similar to that of the builtin
46 * `interp create` command, and is intended to generate names for created
47 * objects of a similar nature.
48 *
49 * TODO: add a int* parameter so that functions which need large numbers of
50 * unique names can keep track of the lower bound between calls,thereby turning
51 * N^2 to N. It'll be alchemy for the 21st century.
52 */
53char* unique_name(Tcl_Interp* interp, char* prefix) {
54    char* result = malloc(strlen(prefix) + TCL_INTEGER_SPACE + 1);
55    Tcl_CmdInfo info;
56    int i;
57    for (i=0; ; i++) {
58        sprintf(result, "%s%d", prefix, i);
59        if (Tcl_GetCommandInfo(interp, result, &info) == 0) {
60            break;
61        }
62    }
63    return result;
64}
65
66/**
67 * Parses flags given to a Tcl command.
68 *
69 * Starting at `objv[start]`, this function will loop through the remaining
70 * arguments until a non-flag argument is found, or an END_FLAGS flag is found,
71 * or an invalid flag is found. In the first two cases, TCL_OK will be returned
72 * and `start` will be moved to the first non-flag argument; in the third,
73 * TCL_ERROR will be returned.
74 *
75 * It is recommended that all callers of this function include the entry
76 * `{ "--", END_FLAGS }` in the NULL-terminated list `options`. For other,
77 * non-zero flag values in `options`, flags will be bitwise or'ed by that value.
78 *
79 * Note that `alpha -beta gamma -delta epsilon` will be recognized as three
80 * arguments following one flag. This could be changed but would make things
81 * much more difficult.
82 *
83 * TODO: support flags of the form ?-flag value?. No functions currently have a
84 * use for this yet, so it's not a priority, but it should be there for
85 * completeness.
86 */
87int parse_flags(Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[], int* start,
88        option_spec options[], int* flags) {
89    int i;
90    int index;
91    *flags = 0;
92    for (i=*start; i<objc; i++) {
93        if (Tcl_GetString(objv[i])[0] != '-') {
94            break;
95        }
96        if (Tcl_GetIndexFromObjStruct(interp, objv[i], options,
97                    sizeof(option_spec), "option", 0, &index) == TCL_OK) {
98            if (options[index].flag == END_FLAGS) {
99                i++;
100                break;
101            } else {
102                *flags |= options[index].flag;
103            }
104        } else {
105            return TCL_ERROR;
106        }
107    }
108    *start = i;
109    return TCL_OK;
110}
111
112/**
113 * Retrieves the object whose proc is named by `name`.
114 *
115 * A common design pattern is to have an object be a proc whose clientData
116 * points to the object and whose function points to an object function. This
117 * function retrieves such an object.
118 *
119 * `proc` is used to verify that a proc names an instance of the object. If not,
120 * `type` is used to construct an appropriate error message before it returns
121 * NULL.
122 */
123void* get_object(Tcl_Interp* interp, char* name, char* type,
124        Tcl_ObjCmdProc* proc, reg_error* errPtr) {
125    Tcl_CmdInfo info;
126    if (Tcl_GetCommandInfo(interp, name, &info) && info.objProc == proc){
127        return info.objClientData;
128    } else {
129        errPtr->code = "registry::not-found";
130        errPtr->description = sqlite3_mprintf("could not find %s \"%s\"", type,
131                name);
132        errPtr->free = (reg_error_destructor*)sqlite3_free;
133        return NULL;
134    }
135}
136
137/**
138 * Sets the object whose proc is named by `name`.
139 *
140 * See the documentation for `get_object`. This function registers such an
141 * object, and additionally requires the `deleteProc` argument, which will be
142 * used to free the object.
143 *
144 * TODO: cause the error used here not to leak memory. This probably needs to be
145 *       addressed as a generic "reg_error_free" routine
146 */
147int set_object(Tcl_Interp* interp, char* name, void* value, char* type,
148        Tcl_ObjCmdProc* proc, Tcl_CmdDeleteProc* deleteProc, reg_error* errPtr){
149    Tcl_CmdInfo info;
150    if (Tcl_GetCommandInfo(interp, name, &info) && info.objProc == proc) {
151        errPtr->code = "registry::duplicate-object";
152        errPtr->description = sqlite3_mprintf("%s named \"%s\" already exists, "
153                "cannot create", type, name);
154        errPtr->free = (reg_error_destructor*)sqlite3_free;
155        return 0;
156    }
157    Tcl_CreateObjCommand(interp, name, proc, value, deleteProc);
158    return 1;
159}
160
161/**
162 * Sets a given name to be an entry object.
163 *
164 * @param [in] interp  Tcl interpreter to create the entry within
165 * @param [in] name    name to associate the given entry with
166 * @param [in] entry   entry to associate with the given name
167 * @param [out] errPtr description of error if it couldn't be set
168 * @return             true if success; false if failure
169 * @see set_object
170 */
171int set_entry(Tcl_Interp* interp, char* name, reg_entry* entry,
172        reg_error* errPtr) {
173    if (set_object(interp, name, entry, "entry", entry_obj_cmd, NULL,
174                errPtr)) {
175        int size = strlen(name) + 1;
176        entry->proc = malloc(size*sizeof(char));
177        memcpy(entry->proc, name, size);
178        return 1;
179    }
180    return 0;
181}
182
183/**
184 * Reports a sqlite3 error to Tcl.
185 *
186 * Queries the database for the most recent error message and sets it as the
187 * result of the given interpreter. If a query is optionally passed, also
188 * records what it was.
189 */
190void set_sqlite_result(Tcl_Interp* interp, sqlite3* db, const char* query) {
191    Tcl_ResetResult(interp);
192    Tcl_SetErrorCode(interp, "registry::sqlite-error", NULL);
193    if (query == NULL) {
194        Tcl_AppendResult(interp, "sqlite error: ", sqlite3_errmsg(db), NULL);
195    } else {
196        Tcl_AppendResult(interp, "sqlite error executing \"", query, "\": ",
197                sqlite3_errmsg(db), NULL);
198    }
199}
200
201/**
202 * Sets the result of the interpreter to all objects returned by a query.
203 *
204 * This function executes `query` on `db` It expects that the query will return
205 * records of a single column, `rowid`. It will then use `prefix` to construct
206 * unique names for these records, and call `setter` to construct their proc
207 * objects. The result of `interp` will be set to a list of all such objects.
208 *
209 * If TCL_OK is returned, then a list is in the result. If TCL_ERROR is, then an
210 * error is there.
211 */
212int all_objects(Tcl_Interp* interp, sqlite3* db, char* query, char* prefix,
213        set_object_function* setter) {
214    sqlite3_stmt* stmt;
215    if (sqlite3_prepare(db, query, -1, &stmt, NULL) == SQLITE_OK) {
216        Tcl_Obj* result = Tcl_NewListObj(0, NULL);
217        Tcl_SetObjResult(interp, result);
218        while (sqlite3_step(stmt) == SQLITE_ROW) {
219            sqlite_int64 rowid = sqlite3_column_int64(stmt, 0);
220            char* name = unique_name(interp, prefix);
221            if (setter(interp, name, rowid) == TCL_OK) {
222                Tcl_Obj* element = Tcl_NewStringObj(name, -1);
223                Tcl_ListObjAppendElement(interp, result, element);
224                free(name);
225            } else {
226                free(name);
227                return TCL_ERROR;
228            }
229        }
230        return TCL_OK;
231    } else {
232        sqlite3_free(query);
233        set_sqlite_result(interp, db, query);
234        return TCL_ERROR;
235    }
236}
237
238const char* string_or_null(Tcl_Obj* obj) {
239    const char* string = Tcl_GetString(obj);
240    if (string[0] == '\0') {
241        return NULL;
242    } else {
243        return string;
244    }
245}
246
247int recast(void* userdata, cast_function* fn, free_function* del, void*** outv,
248        void** inv, int inc, reg_error* errPtr) {
249    void** result = malloc(inc*sizeof(void*));
250    int i;
251    for (i=0; i<inc; i++) {
252        if (!fn(userdata, &result[i], inv[i], errPtr)) {
253            if (del != NULL) {
254                for ( ; i>=0; i--) {
255                    del(userdata, result[i]);
256                }
257            }
258            free(result);
259            return 0;
260        }
261    }
262    *outv = result;
263    return 1;
264}
265
266int entry_to_obj(Tcl_Interp* interp, Tcl_Obj** obj, reg_entry* entry,
267        reg_error* errPtr) {
268    if (entry->proc == NULL) {
269        char* name = unique_name(interp, "::registry::entry");
270        if (!set_entry(interp, name, entry, errPtr)) {
271            free(name);
272            return 0;
273        }
274        free(name);
275    }
276    *obj = Tcl_NewStringObj(entry->proc, -1);
277    return 1;
278}
279
280int list_entry_to_obj(Tcl_Interp* interp, Tcl_Obj*** objs,
281        reg_entry** entries, int entry_count, reg_error* errPtr) {
282    return recast(interp, (cast_function*)entry_to_obj, NULL, (void***)objs,
283            (void**)entries, entry_count, errPtr);
284}
285
286static int obj_to_string(void* userdata UNUSED, char** string, Tcl_Obj* obj,
287        reg_error* errPtr UNUSED) {
288    *string = Tcl_GetString(obj);
289    return 1;
290}
291
292int list_obj_to_string(char*** strings, Tcl_Obj** objv, int objc,
293        reg_error* errPtr) {
294    return recast(NULL, (cast_function*)obj_to_string, NULL, (void***)strings,
295            (void**)objv, objc, errPtr);
296}
297
298static int string_to_obj(void* userdata UNUSED, Tcl_Obj** obj, char* string,
299        reg_error* errPtr UNUSED) {
300    *obj = Tcl_NewStringObj(string, -1);
301    return 1;
302}
303
304static void free_obj(void* userdata UNUSED, Tcl_Obj* obj) {
305    Tcl_DecrRefCount(obj);
306}
307
308int list_string_to_obj(Tcl_Obj*** objv, char** strings, int objc,
309        reg_error* errPtr) {
310    return recast(NULL, (cast_function*)string_to_obj, (free_function*)free_obj,
311            (void***)objv, (void**)strings, objc, errPtr);
312}
Note: See TracBrowser for help on using the repository browser.