shared_source/c_tcl_base_7_5_w_mods/tcllink.c

/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tcllink.c,v 1.1.1.1 2001/06/13 04:42:27 dtashley Exp $ */

/* 
 * tclLink.c --
 *
 *      This file implements linked variables (a C variable that is
 *      tied to a Tcl variable).  The idea of linked variables was
 *      first suggested by Andreas Stolcke and this implementation is
 *      based heavily on a prototype implementation provided by
 *      him.
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcllink.c,v 1.1.1.1 2001/06/13 04:42:27 dtashley Exp $
 */

#include "tclInt.h"

/*
 * For each linked variable there is a data structure of the following
 * type, which describes the link and is the clientData for the trace
 * set on the Tcl variable.
 */

typedef struct Link {
    Tcl_Interp *interp;         /* Interpreter containing Tcl variable. */
    char *varName;              /* Name of variable (must be global).  This
                                 * is needed during trace callbacks, since
                                 * the actual variable may be aliased at
                                 * that time via upvar. */
    char *addr;                 /* Location of C variable. */
    int type;                   /* Type of link (TCL_LINK_INT, etc.). */
    union {
        int i;
        double d;
    } lastValue;                /* Last known value of C variable;  used to
                                 * avoid string conversions. */
    int flags;                  /* Miscellaneous one-bit values;  see below
                                 * for definitions. */
} Link;

/*
 * Definitions for flag bits:
 * LINK_READ_ONLY -             1 means errors should be generated if Tcl
 *                              script attempts to write variable.
 * LINK_BEING_UPDATED -         1 means that a call to Tcl_UpdateLinkedVar
 *                              is in progress for this variable, so
 *                              trace callbacks on the variable should
 *                              be ignored.
 */

#define LINK_READ_ONLY          1
#define LINK_BEING_UPDATED      2

/*
 * Forward references to procedures defined later in this file:
 */

static char *           LinkTraceProc _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, char *name1, char *name2,
                            int flags));
static char *           StringValue _ANSI_ARGS_((Link *linkPtr,
                            char *buffer));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinkVar --
 *
 *      Link a C variable to a Tcl variable so that changes to either
 *      one causes the other to change.
 *
 * Results:
 *      The return value is TCL_OK if everything went well or TCL_ERROR
 *      if an error occurred (the interp's result is also set after
 *      errors).
 *
 * Side effects:
 *      The value at *addr is linked to the Tcl variable "varName",
 *      using "type" to convert between string values for Tcl and
 *      binary values for *addr.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LinkVar(interp, varName, addr, type)
    Tcl_Interp *interp;         /* Interpreter in which varName exists. */
    char *varName;              /* Name of a global variable in interp. */
    char *addr;                 /* Address of a C variable to be linked
                                 * to varName. */
    int type;                   /* Type of C variable: TCL_LINK_INT, etc. 
                                 * Also may have TCL_LINK_READ_ONLY
                                 * OR'ed in. */
{
    Link *linkPtr;
    char buffer[TCL_DOUBLE_SPACE];
    int code;

    linkPtr = (Link *) ckalloc(sizeof(Link));
    linkPtr->interp = interp;
    linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
    strcpy(linkPtr->varName, varName);
    linkPtr->addr = addr;
    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
    if (type & TCL_LINK_READ_ONLY) {
        linkPtr->flags = LINK_READ_ONLY;
    } else {
        linkPtr->flags = 0;
    }
    if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
            TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
        ckfree(linkPtr->varName);
        ckfree((char *) linkPtr);
        return TCL_ERROR;
    }
    code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
            |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
            (ClientData) linkPtr);
    if (code != TCL_OK) {
        ckfree(linkPtr->varName);
        ckfree((char *) linkPtr);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnlinkVar --
 *
 *      Destroy the link between a Tcl variable and a C variable.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      If "varName" was previously linked to a C variable, the link
 *      is broken to make the variable independent.  If there was no
 *      previous link for "varName" then nothing happens.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UnlinkVar(interp, varName)
    Tcl_Interp *interp;         /* Interpreter containing variable to unlink. */
    char *varName;              /* Global variable in interp to unlink. */
{
    Link *linkPtr;

    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
            LinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL) {
        return;
    }
    Tcl_UntraceVar(interp, varName,
            TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
            LinkTraceProc, (ClientData) linkPtr);
    ckfree(linkPtr->varName);
    ckfree((char *) linkPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpdateLinkedVar --
 *
 *      This procedure is invoked after a linked variable has been
 *      changed by C code.  It updates the Tcl variable so that
 *      traces on the variable will trigger.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The Tcl variable "varName" is updated from its C value,
 *      causing traces on the variable to trigger.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UpdateLinkedVar(interp, varName)
    Tcl_Interp *interp;         /* Interpreter containing variable. */
    char *varName;              /* Name of global variable that is linked. */
{
    Link *linkPtr;
    char buffer[TCL_DOUBLE_SPACE];
    int savedFlag;

    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
            LinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL) {
        return;
    }
    savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
    linkPtr->flags |= LINK_BEING_UPDATED;
    Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
            TCL_GLOBAL_ONLY);
    linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}

/*
 *----------------------------------------------------------------------
 *
 * LinkTraceProc --
 *
 *      This procedure is invoked when a linked Tcl variable is read,
 *      written, or unset from Tcl.  It's responsible for keeping the
 *      C variable in sync with the Tcl variable.
 *
 * Results:
 *      If all goes well, NULL is returned; otherwise an error message
 *      is returned.
 *
 * Side effects:
 *      The C variable may be updated to make it consistent with the
 *      Tcl variable, or the Tcl variable may be overwritten to reject
 *      a modification.
 *
 *----------------------------------------------------------------------
 */

static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;      /* Contains information about the link. */
    Tcl_Interp *interp;         /* Interpreter containing Tcl variable. */
    char *name1;                /* First part of variable name. */
    char *name2;                /* Second part of variable name. */
    int flags;                  /* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *) clientData;
    int changed;
    char buffer[TCL_DOUBLE_SPACE];
    char *value, **pp, *result;
    Tcl_Obj *objPtr;

    /*
     * If the variable is being unset, then just re-create it (with a
     * trace) unless the whole interpreter is going away.
     */

    if (flags & TCL_TRACE_UNSETS) {
        if (flags & TCL_INTERP_DESTROYED) {
            ckfree(linkPtr->varName);
            ckfree((char *) linkPtr);
        } else if (flags & TCL_TRACE_DESTROYED) {
            Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
                    TCL_GLOBAL_ONLY);
            Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY
                    |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
                    LinkTraceProc, (ClientData) linkPtr);
        }
        return NULL;
    }

    /*
     * If we were invoked because of a call to Tcl_UpdateLinkedVar, then
     * don't do anything at all.  In particular, we don't want to get
     * upset that the variable is being modified, even if it is
     * supposed to be read-only.
     */

    if (linkPtr->flags & LINK_BEING_UPDATED) {
        return NULL;
    }

    /*
     * For read accesses, update the Tcl variable if the C variable
     * has changed since the last time we updated the Tcl variable.
     */

    if (flags & TCL_TRACE_READS) {
        switch (linkPtr->type) {
            case TCL_LINK_INT:
            case TCL_LINK_BOOLEAN:
                changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
                break;
            case TCL_LINK_DOUBLE:
                changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
                break;
            case TCL_LINK_STRING:
                changed = 1;
                break;
            default:
                return "internal error: bad linked variable type";
        }
        if (changed) {
            Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
                    TCL_GLOBAL_ONLY);
        }
        return NULL;
    }

    /*
     * For writes, first make sure that the variable is writable.  Then
     * convert the Tcl value to C if possible.  If the variable isn't
     * writable or can't be converted, then restore the varaible's old
     * value and return an error.  Another tricky thing: we have to save
     * and restore the interpreter's result, since the variable access
     * could occur when the result has been partially set.
     */

    if (linkPtr->flags & LINK_READ_ONLY) {
        Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
                TCL_GLOBAL_ONLY);
        return "linked variable is read-only";
    }
    value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY);
    if (value == NULL) {
        /*
         * This shouldn't ever happen.
         */
        return "internal error: linked variable couldn't be read";
    }

    objPtr = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(objPtr);
    Tcl_ResetResult(interp);
    result = NULL;

    switch (linkPtr->type) {
        case TCL_LINK_INT:
            if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
                Tcl_SetObjResult(interp, objPtr);
                Tcl_SetVar(interp, linkPtr->varName,
                        StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
                result = "variable must have integer value";
                goto end;
            }
            *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
            break;
        case TCL_LINK_DOUBLE:
            if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
                    != TCL_OK) {
                Tcl_SetObjResult(interp, objPtr);
                Tcl_SetVar(interp, linkPtr->varName,
                        StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
                result = "variable must have real value";
                goto end;
            }
            *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
            break;
        case TCL_LINK_BOOLEAN:
            if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
                    != TCL_OK) {
                Tcl_SetObjResult(interp, objPtr);
                Tcl_SetVar(interp, linkPtr->varName,
                        StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
                result = "variable must have boolean value";
                goto end;
            }
            *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
            break;
        case TCL_LINK_STRING:
            pp = (char **)(linkPtr->addr);
            if (*pp != NULL) {
                ckfree(*pp);
            }
            *pp = (char *) ckalloc((unsigned) (strlen(value) + 1));
            strcpy(*pp, value);
            break;
        default:
            return "internal error: bad linked variable type";
    }
    end:
    Tcl_DecrRefCount(objPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * StringValue --
 *
 *      Converts the value of a C variable to a string for use in a
 *      Tcl variable to which it is linked.
 *
 * Results:
 *      The return value is a pointer to a string that represents
 *      the value of the C variable given by linkPtr.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static char *
StringValue(linkPtr, buffer)
    Link *linkPtr;              /* Structure describing linked variable. */
    char *buffer;               /* Small buffer to use for converting
                                 * values.  Must have TCL_DOUBLE_SPACE
                                 * bytes or more. */
{
    char *p;

    switch (linkPtr->type) {
        case TCL_LINK_INT:
            linkPtr->lastValue.i = *(int *)(linkPtr->addr);
            TclFormatInt(buffer, linkPtr->lastValue.i);
            return buffer;
        case TCL_LINK_DOUBLE:
            linkPtr->lastValue.d = *(double *)(linkPtr->addr);
            Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer);
            return buffer;
        case TCL_LINK_BOOLEAN:
            linkPtr->lastValue.i = *(int *)(linkPtr->addr);
            if (linkPtr->lastValue.i != 0) {
                return "1";
            }
            return "0";
        case TCL_LINK_STRING:
            p = *(char **)(linkPtr->addr);
            if (p == NULL) {
                return "NULL";
            }
            return p;
    }

    /*
     * This code only gets executed if the link type is unknown
     * (shouldn't ever happen).
     */

    return "??";
}


/* $History: tcllink.c $
 * 
 * *****************  Version 1  *****************
 * User: Dtashley     Date: 1/02/01    Time: 1:33a
 * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
 * Initial check-in.
 */ 

/* End of TCLLINK.C */
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 */