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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (show annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 3 months 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 /*$Header$ */
2 /*
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 /* End of tcllink.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25