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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25