Fork me on GitHub

source: git/external/tcl/tclLink.c

Last change on this file was d7d2da3, checked in by pavel <pavel@…>, 12 years ago

move branches/ModularDelphes to trunk
  • Property mode set to 100644
File size: 12.4 KB
Line 
1/*
2 * tclLink.c --
3 *
4 * This file implements linked variables (a C variable that is
5 * tied to a Tcl variable). The idea of linked variables was
6 * first suggested by Andreas Stolcke and this implementation is
7 * based heavily on a prototype implementation provided by
8 * him.
9 *
10 * Copyright (c) 1993 The Regents of the University of California.
11 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
12 *
13 * See the file "license.terms" for information on usage and redistribution
14 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 *
16 * RCS: @(#) $Id: tclLink.c,v 1.1 2008-06-04 13:58:07 demin Exp $
17 */
18
19#include "tclInt.h"
20
21/*
22 * For each linked variable there is a data structure of the following
23 * type, which describes the link and is the clientData for the trace
24 * set on the Tcl variable.
25 */
26
27typedef struct Link {
28 Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
29 char *varName; /* Name of variable (must be global). This
30 * is needed during trace callbacks, since
31 * the actual variable may be aliased at
32 * that time via upvar. */
33 char *addr; /* Location of C variable. */
34 int type; /* Type of link (TCL_LINK_INT, etc.). */
35 union {
36 int i;
37 double d;
38 } lastValue; /* Last known value of C variable; used to
39 * avoid string conversions. */
40 int flags; /* Miscellaneous one-bit values; see below
41 * for definitions. */
42} Link;
43
44/*
45 * Definitions for flag bits:
46 * LINK_READ_ONLY - 1 means errors should be generated if Tcl
47 * script attempts to write variable.
48 * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar
49 * is in progress for this variable, so
50 * trace callbacks on the variable should
51 * be ignored.
52 */
53
54#define LINK_READ_ONLY 1
55#define LINK_BEING_UPDATED 2
56
57/*
58 * Forward references to procedures defined later in this file:
59 */
60
61static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData,
62 Tcl_Interp *interp, char *name1, char *name2,
63 int flags));
64static char * StringValue _ANSI_ARGS_((Link *linkPtr,
65 char *buffer));
66
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 (interp->result is also set after errors).
79 *
80 * Side effects:
81 * The value at *addr is linked to the Tcl variable "varName",
82 * using "type" to convert between string values for Tcl and
83 * binary values for *addr.
84 *
85 *----------------------------------------------------------------------
86 */
87
88int
89Tcl_LinkVar(interp, varName, addr, type)
90 Tcl_Interp *interp; /* Interpreter in which varName exists. */
91 char *varName; /* Name of a global variable in interp. */
92 char *addr; /* Address of a C variable to be linked
93 * to varName. */
94 int type; /* Type of C variable: TCL_LINK_INT, etc.
95 * Also may have TCL_LINK_READ_ONLY
96 * OR'ed in. */
97{
98 Link *linkPtr;
99 char buffer[TCL_DOUBLE_SPACE];
100 int code;
101
102 linkPtr = (Link *) ckalloc(sizeof(Link));
103 linkPtr->interp = interp;
104 linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
105 strcpy(linkPtr->varName, varName);
106 linkPtr->addr = addr;
107 linkPtr->type = type & ~TCL_LINK_READ_ONLY;
108 if (type & TCL_LINK_READ_ONLY) {
109 linkPtr->flags = LINK_READ_ONLY;
110 } else {
111 linkPtr->flags = 0;
112 }
113 if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
114 TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
115 ckfree(linkPtr->varName);
116 ckfree((char *) linkPtr);
117 return TCL_ERROR;
118 }
119 code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
120 |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
121 (ClientData) linkPtr);
122 if (code != TCL_OK) {
123 ckfree(linkPtr->varName);
124 ckfree((char *) linkPtr);
125 }
126 return code;
127}
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
148void
149Tcl_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 *
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
187void
188Tcl_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 *
212 * LinkTraceProc --
213 *
214 * This procedure is invoked when a linked Tcl variable is read,
215 * written, or unset from Tcl. It's responsible for keeping the
216 * C variable in sync with the Tcl variable.
217 *
218 * Results:
219 * If all goes well, NULL is returned; otherwise an error message
220 * is returned.
221 *
222 * Side effects:
223 * The C variable may be updated to make it consistent with the
224 * Tcl variable, or the Tcl variable may be overwritten to reject
225 * a modification.
226 *
227 *----------------------------------------------------------------------
228 */
229
230static char *
231LinkTraceProc(clientData, interp, name1, name2, flags)
232 ClientData clientData; /* Contains information about the link. */
233 Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
234 char *name1; /* First part of variable name. */
235 char *name2; /* Second part of variable name. */
236 int flags; /* Miscellaneous additional information. */
237{
238 Link *linkPtr = (Link *) clientData;
239 int changed;
240 char buffer[TCL_DOUBLE_SPACE];
241 char *value, **pp;
242 Tcl_DString savedResult;
243
244 /*
245 * If the variable is being unset, then just re-create it (with a
246 * trace) unless the whole interpreter is going away.
247 */
248
249 if (flags & TCL_TRACE_UNSETS) {
250 if (flags & TCL_INTERP_DESTROYED) {
251 ckfree(linkPtr->varName);
252 ckfree((char *) linkPtr);
253 } else if (flags & TCL_TRACE_DESTROYED) {
254 Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
255 TCL_GLOBAL_ONLY);
256 Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY
257 |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
258 LinkTraceProc, (ClientData) linkPtr);
259 }
260 return NULL;
261 }
262
263 /*
264 * If we were invoked because of a call to Tcl_UpdateLinkedVar, then
265 * don't do anything at all. In particular, we don't want to get
266 * upset that the variable is being modified, even if it is
267 * supposed to be read-only.
268 */
269
270 if (linkPtr->flags & LINK_BEING_UPDATED) {
271 return NULL;
272 }
273
274 /*
275 * For read accesses, update the Tcl variable if the C variable
276 * has changed since the last time we updated the Tcl variable.
277 */
278
279 if (flags & TCL_TRACE_READS) {
280 switch (linkPtr->type) {
281 case TCL_LINK_INT:
282 case TCL_LINK_BOOLEAN:
283 changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
284 break;
285 case TCL_LINK_DOUBLE:
286 changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
287 break;
288 case TCL_LINK_STRING:
289 changed = 1;
290 break;
291 default:
292 return "internal error: bad linked variable type";
293 }
294 if (changed) {
295 Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
296 TCL_GLOBAL_ONLY);
297 }
298 return NULL;
299 }
300
301 /*
302 * For writes, first make sure that the variable is writable. Then
303 * convert the Tcl value to C if possible. If the variable isn't
304 * writable or can't be converted, then restore the varaible's old
305 * value and return an error. Another tricky thing: we have to save
306 * and restore the interpreter's result, since the variable access
307 * could occur when the result has been partially set.
308 */
309
310 if (linkPtr->flags & LINK_READ_ONLY) {
311 Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
312 TCL_GLOBAL_ONLY);
313 return "linked variable is read-only";
314 }
315 value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY);
316 if (value == NULL) {
317 /*
318 * This shouldn't ever happen.
319 */
320 return "internal error: linked variable couldn't be read";
321 }
322 Tcl_DStringInit(&savedResult);
323 Tcl_DStringAppend(&savedResult, interp->result, -1);
324 Tcl_ResetResult(interp);
325 switch (linkPtr->type) {
326 case TCL_LINK_INT:
327 if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
328 Tcl_DStringResult(interp, &savedResult);
329 Tcl_SetVar(interp, linkPtr->varName,
330 StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
331 return "variable must have integer value";
332 }
333 *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
334 break;
335 case TCL_LINK_DOUBLE:
336 if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
337 != TCL_OK) {
338 Tcl_DStringResult(interp, &savedResult);
339 Tcl_SetVar(interp, linkPtr->varName,
340 StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
341 return "variable must have real value";
342 }
343 *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
344 break;
345 case TCL_LINK_BOOLEAN:
346 if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
347 != TCL_OK) {
348 Tcl_DStringResult(interp, &savedResult);
349 Tcl_SetVar(interp, linkPtr->varName,
350 StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
351 return "variable must have boolean value";
352 }
353 *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
354 break;
355 case TCL_LINK_STRING:
356 pp = (char **)(linkPtr->addr);
357 if (*pp != NULL) {
358 ckfree(*pp);
359 }
360 *pp = (char *) ckalloc((unsigned) (strlen(value) + 1));
361 strcpy(*pp, value);
362 break;
363 default:
364 return "internal error: bad linked variable type";
365 }
366 Tcl_DStringResult(interp, &savedResult);
367 return NULL;
368}
369
370
371/*
372 *----------------------------------------------------------------------
373 *
374 * StringValue --
375 *
376 * Converts the value of a C variable to a string for use in a
377 * Tcl variable to which it is linked.
378 *
379 * Results:
380 * The return value is a pointer
381 to a string that represents
382 * the value of the C variable given by linkPtr.
383 *
384 * Side effects:
385 * None.
386 *
387 *----------------------------------------------------------------------
388 */
389
390static char *
391StringValue(linkPtr, buffer)
392 Link *linkPtr; /* Structure describing linked variable. */
393 char *buffer; /* Small buffer to use for converting
394 * values. Must have TCL_DOUBLE_SPACE
395 * bytes or more. */
396{
397 char *p;
398
399 switch (linkPtr->type) {
400 case TCL_LINK_INT:
401 linkPtr->lastValue.i = *(int *)(linkPtr->addr);
402 TclFormatInt(buffer, linkPtr->lastValue.i);
403 return buffer;
404 case TCL_LINK_DOUBLE:
405 linkPtr->lastValue.d = *(double *)(linkPtr->addr);
406 Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer);
407 return buffer;
408 case TCL_LINK_BOOLEAN:
409 linkPtr->lastValue.i = *(int *)(linkPtr->addr);
410 if (linkPtr->lastValue.i != 0) {
411 return "1";
412 }
413 return "0";
414 case TCL_LINK_STRING:
415 p = *(char **)(linkPtr->addr);
416 if (p == NULL) {
417 return "NULL";
418 }
419 return p;
420 }
421
422 /*
423 * This code only gets executed if the link type is unknown
424 * (shouldn't ever happen).
425 */
426
427 return "??";
428}
Note: See TracBrowser for help on using the repository browser.