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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 42 - (show annotations) (download)
Fri Oct 14 01:50:00 2016 UTC (8 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 13547 byte(s)
Move shared source code to commonize.
1 /* $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