/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tcllink.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tcllink.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (hide annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (7 years, 4 months ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tcl_base/tcllink.c
File MIME type: text/plain
File size: 13547 byte(s)
Initial commit.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tcllink.c,v 1.1.1.1 2001/06/13 04:42:27 dtashley Exp $ */
2    
3     /*
4     * tclLink.c --
5     *
6     * This file implements linked variables (a C variable that is
7     * tied to a Tcl variable). The idea of linked variables was
8     * first suggested by Andreas Stolcke and this implementation is
9     * based heavily on a prototype implementation provided by
10     * him.
11     *
12     * Copyright (c) 1993 The Regents of the University of California.
13     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
14     *
15     * See the file "license.terms" for information on usage and redistribution
16     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
17     *
18     * RCS: @(#) $Id: tcllink.c,v 1.1.1.1 2001/06/13 04:42:27 dtashley Exp $
19     */
20    
21     #include "tclInt.h"
22    
23     /*
24     * For each linked variable there is a data structure of the following
25     * type, which describes the link and is the clientData for the trace
26     * set on the Tcl variable.
27     */
28    
29     typedef struct Link {
30     Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
31     char *varName; /* Name of variable (must be global). This
32     * is needed during trace callbacks, since
33     * the actual variable may be aliased at
34     * that time via upvar. */
35     char *addr; /* Location of C variable. */
36     int type; /* Type of link (TCL_LINK_INT, etc.). */
37     union {
38     int i;
39     double d;
40     } lastValue; /* Last known value of C variable; used to
41     * avoid string conversions. */
42     int flags; /* Miscellaneous one-bit values; see below
43     * for definitions. */
44     } Link;
45    
46     /*
47     * Definitions for flag bits:
48     * LINK_READ_ONLY - 1 means errors should be generated if Tcl
49     * script attempts to write variable.
50     * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar
51     * is in progress for this variable, so
52     * trace callbacks on the variable should
53     * be ignored.
54     */
55    
56     #define LINK_READ_ONLY 1
57     #define LINK_BEING_UPDATED 2
58    
59     /*
60     * Forward references to procedures defined later in this file:
61     */
62    
63     static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData,
64     Tcl_Interp *interp, char *name1, char *name2,
65     int flags));
66     static char * StringValue _ANSI_ARGS_((Link *linkPtr,
67     char *buffer));
68    
69     /*
70     *----------------------------------------------------------------------
71     *
72     * Tcl_LinkVar --
73     *
74     * Link a C variable to a Tcl variable so that changes to either
75     * one causes the other to change.
76     *
77     * Results:
78     * The return value is TCL_OK if everything went well or TCL_ERROR
79     * if an error occurred (the interp's result is also set after
80     * errors).
81     *
82     * Side effects:
83     * The value at *addr is linked to the Tcl variable "varName",
84     * using "type" to convert between string values for Tcl and
85     * binary values for *addr.
86     *
87     *----------------------------------------------------------------------
88     */
89    
90     int
91     Tcl_LinkVar(interp, varName, addr, type)
92     Tcl_Interp *interp; /* Interpreter in which varName exists. */
93     char *varName; /* Name of a global variable in interp. */
94     char *addr; /* Address of a C variable to be linked
95     * to varName. */
96     int type; /* Type of C variable: TCL_LINK_INT, etc.
97     * Also may have TCL_LINK_READ_ONLY
98     * OR'ed in. */
99     {
100     Link *linkPtr;
101     char buffer[TCL_DOUBLE_SPACE];
102     int code;
103    
104     linkPtr = (Link *) ckalloc(sizeof(Link));
105     linkPtr->interp = interp;
106     linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
107     strcpy(linkPtr->varName, varName);
108     linkPtr->addr = addr;
109     linkPtr->type = type & ~TCL_LINK_READ_ONLY;
110     if (type & TCL_LINK_READ_ONLY) {
111     linkPtr->flags = LINK_READ_ONLY;
112     } else {
113     linkPtr->flags = 0;
114     }
115     if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
116     TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
117     ckfree(linkPtr->varName);
118     ckfree((char *) linkPtr);
119     return TCL_ERROR;
120     }
121     code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
122     |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
123     (ClientData) linkPtr);
124     if (code != TCL_OK) {
125     ckfree(linkPtr->varName);
126     ckfree((char *) linkPtr);
127     }
128     return code;
129     }
130    
131     /*
132     *----------------------------------------------------------------------
133     *
134     * Tcl_UnlinkVar --
135     *
136     * Destroy the link between a Tcl variable and a C variable.
137     *
138     * Results:
139     * None.
140     *
141     * Side effects:
142     * If "varName" was previously linked to a C variable, the link
143     * is broken to make the variable independent. If there was no
144     * previous link for "varName" then nothing happens.
145     *
146     *----------------------------------------------------------------------
147     */
148    
149     void
150     Tcl_UnlinkVar(interp, varName)
151     Tcl_Interp *interp; /* Interpreter containing variable to unlink. */
152     char *varName; /* Global variable in interp to unlink. */
153     {
154     Link *linkPtr;
155    
156     linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
157     LinkTraceProc, (ClientData) NULL);
158     if (linkPtr == NULL) {
159     return;
160     }
161     Tcl_UntraceVar(interp, varName,
162     TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
163     LinkTraceProc, (ClientData) linkPtr);
164     ckfree(linkPtr->varName);
165     ckfree((char *) linkPtr);
166     }
167    
168     /*
169     *----------------------------------------------------------------------
170     *
171     * Tcl_UpdateLinkedVar --
172     *
173     * This procedure is invoked after a linked variable has been
174     * changed by C code. It updates the Tcl variable so that
175     * traces on the variable will trigger.
176     *
177     * Results:
178     * None.
179     *
180     * Side effects:
181     * The Tcl variable "varName" is updated from its C value,
182     * causing traces on the variable to trigger.
183     *
184     *----------------------------------------------------------------------
185     */
186    
187     void
188     Tcl_UpdateLinkedVar(interp, varName)
189     Tcl_Interp *interp; /* Interpreter containing variable. */
190     char *varName; /* Name of global variable that is linked. */
191     {
192     Link *linkPtr;
193     char buffer[TCL_DOUBLE_SPACE];
194     int savedFlag;
195    
196     linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
197     LinkTraceProc, (ClientData) NULL);
198     if (linkPtr == NULL) {
199     return;
200     }
201     savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
202     linkPtr->flags |= LINK_BEING_UPDATED;
203     Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
204     TCL_GLOBAL_ONLY);
205     linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
206     }
207    
208     /*
209     *----------------------------------------------------------------------
210     *
211     * LinkTraceProc --
212     *
213     * This procedure is invoked when a linked Tcl variable is read,
214     * written, or unset from Tcl. It's responsible for keeping the
215     * C variable in sync with the Tcl variable.
216     *
217     * Results:
218     * If all goes well, NULL is returned; otherwise an error message
219     * is returned.
220     *
221     * Side effects:
222     * The C variable may be updated to make it consistent with the
223     * Tcl variable, or the Tcl variable may be overwritten to reject
224     * a modification.
225     *
226     *----------------------------------------------------------------------
227     */
228    
229     static char *
230     LinkTraceProc(clientData, interp, name1, name2, flags)
231     ClientData clientData; /* Contains information about the link. */
232     Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
233     char *name1; /* First part of variable name. */
234     char *name2; /* Second part of variable name. */
235     int flags; /* Miscellaneous additional information. */
236     {
237     Link *linkPtr = (Link *) clientData;
238     int changed;
239     char buffer[TCL_DOUBLE_SPACE];
240     char *value, **pp, *result;
241     Tcl_Obj *objPtr;
242    
243     /*
244     * If the variable is being unset, then just re-create it (with a
245     * trace) unless the whole interpreter is going away.
246     */
247    
248     if (flags & TCL_TRACE_UNSETS) {
249     if (flags & TCL_INTERP_DESTROYED) {
250     ckfree(linkPtr->varName);
251     ckfree((char *) linkPtr);
252     } else if (flags & TCL_TRACE_DESTROYED) {
253     Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
254     TCL_GLOBAL_ONLY);
255     Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY
256     |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
257     LinkTraceProc, (ClientData) linkPtr);
258     }
259     return NULL;
260     }
261    
262     /*
263     * If we were invoked because of a call to Tcl_UpdateLinkedVar, then
264     * don't do anything at all. In particular, we don't want to get
265     * upset that the variable is being modified, even if it is
266     * supposed to be read-only.
267     */
268    
269     if (linkPtr->flags & LINK_BEING_UPDATED) {
270     return NULL;
271     }
272    
273     /*
274     * For read accesses, update the Tcl variable if the C variable
275     * has changed since the last time we updated the Tcl variable.
276     */
277    
278     if (flags & TCL_TRACE_READS) {
279     switch (linkPtr->type) {
280     case TCL_LINK_INT:
281     case TCL_LINK_BOOLEAN:
282     changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
283     break;
284     case TCL_LINK_DOUBLE:
285     changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
286     break;
287     case TCL_LINK_STRING:
288     changed = 1;
289     break;
290     default:
291     return "internal error: bad linked variable type";
292     }
293     if (changed) {
294     Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
295     TCL_GLOBAL_ONLY);
296     }
297     return NULL;
298     }
299    
300     /*
301     * For writes, first make sure that the variable is writable. Then
302     * convert the Tcl value to C if possible. If the variable isn't
303     * writable or can't be converted, then restore the varaible's old
304     * value and return an error. Another tricky thing: we have to save
305     * and restore the interpreter's result, since the variable access
306     * could occur when the result has been partially set.
307     */
308    
309     if (linkPtr->flags & LINK_READ_ONLY) {
310     Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
311     TCL_GLOBAL_ONLY);
312     return "linked variable is read-only";
313     }
314     value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY);
315     if (value == NULL) {
316     /*
317     * This shouldn't ever happen.
318     */
319     return "internal error: linked variable couldn't be read";
320     }
321    
322     objPtr = Tcl_GetObjResult(interp);
323     Tcl_IncrRefCount(objPtr);
324     Tcl_ResetResult(interp);
325     result = NULL;
326    
327     switch (linkPtr->type) {
328     case TCL_LINK_INT:
329     if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
330     Tcl_SetObjResult(interp, objPtr);
331     Tcl_SetVar(interp, linkPtr->varName,
332     StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
333     result = "variable must have integer value";
334     goto end;
335     }
336     *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
337     break;
338     case TCL_LINK_DOUBLE:
339     if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
340     != TCL_OK) {
341     Tcl_SetObjResult(interp, objPtr);
342     Tcl_SetVar(interp, linkPtr->varName,
343     StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
344     result = "variable must have real value";
345     goto end;
346     }
347     *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
348     break;
349     case TCL_LINK_BOOLEAN:
350     if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
351     != TCL_OK) {
352     Tcl_SetObjResult(interp, objPtr);
353     Tcl_SetVar(interp, linkPtr->varName,
354     StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
355     result = "variable must have boolean value";
356     goto end;
357     }
358     *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
359     break;
360     case TCL_LINK_STRING:
361     pp = (char **)(linkPtr->addr);
362     if (*pp != NULL) {
363     ckfree(*pp);
364     }
365     *pp = (char *) ckalloc((unsigned) (strlen(value) + 1));
366     strcpy(*pp, value);
367     break;
368     default:
369     return "internal error: bad linked variable type";
370     }
371     end:
372     Tcl_DecrRefCount(objPtr);
373     return result;
374     }
375    
376     /*
377     *----------------------------------------------------------------------
378     *
379     * StringValue --
380     *
381     * Converts the value of a C variable to a string for use in a
382     * Tcl variable to which it is linked.
383     *
384     * Results:
385     * The return value is a pointer to a string that represents
386     * the value of the C variable given by linkPtr.
387     *
388     * Side effects:
389     * None.
390     *
391     *----------------------------------------------------------------------
392     */
393    
394     static char *
395     StringValue(linkPtr, buffer)
396     Link *linkPtr; /* Structure describing linked variable. */
397     char *buffer; /* Small buffer to use for converting
398     * values. Must have TCL_DOUBLE_SPACE
399     * bytes or more. */
400     {
401     char *p;
402    
403     switch (linkPtr->type) {
404     case TCL_LINK_INT:
405     linkPtr->lastValue.i = *(int *)(linkPtr->addr);
406     TclFormatInt(buffer, linkPtr->lastValue.i);
407     return buffer;
408     case TCL_LINK_DOUBLE:
409     linkPtr->lastValue.d = *(double *)(linkPtr->addr);
410     Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer);
411     return buffer;
412     case TCL_LINK_BOOLEAN:
413     linkPtr->lastValue.i = *(int *)(linkPtr->addr);
414     if (linkPtr->lastValue.i != 0) {
415     return "1";
416     }
417     return "0";
418     case TCL_LINK_STRING:
419     p = *(char **)(linkPtr->addr);
420     if (p == NULL) {
421     return "NULL";
422     }
423     return p;
424     }
425    
426     /*
427     * This code only gets executed if the link type is unknown
428     * (shouldn't ever happen).
429     */
430    
431     return "??";
432     }
433    
434    
435     /* $History: tcllink.c $
436     *
437     * ***************** Version 1 *****************
438     * User: Dtashley Date: 1/02/01 Time: 1:33a
439     * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
440     * Initial check-in.
441     */
442    
443     /* End of TCLLINK.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25