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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

sf_code/esrgpcpj/shared/tcl_base/tcllink.c revision 25 by dashley, Sat Oct 8 06:43:03 2016 UTC projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tcllink.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $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    /* $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 */
Legend:
Removed from v.25  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25