home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcl2-73c.zip / tcl7.3 / tclLink.c < prev    next >
C/C++ Source or Header  |  1993-07-29  |  11KB  |  362 lines
  1. /* 
  2.  * tclLink.c --
  3.  *
  4.  *    This file implements linked variables (a C variable that is
  5.  *    tied to a Tcl variable).  The idea of linked variables was
  6.  *    first suggested by Andreas Stocke and this implementation is
  7.  *    based heavily on a prototype implementation provided by
  8.  *    him.
  9.  *
  10.  * Copyright (c) 1993 The Regents of the University of California.
  11.  * All rights reserved.
  12.  *
  13.  * Permission is hereby granted, without written agreement and without
  14.  * license or royalty fees, to use, copy, modify, and distribute this
  15.  * software and its documentation for any purpose, provided that the
  16.  * above copyright notice and the following two paragraphs appear in
  17.  * all copies of this software.
  18.  * 
  19.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  20.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  21.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  22.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23.  *
  24.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  25.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  26.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  27.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  28.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  29.  */
  30.  
  31. #ifndef lint
  32. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclLink.c,v 1.4 93/07/29 15:24:05 ouster Exp $ SPRITE (Berkeley)";
  33. #endif /* not lint */
  34.  
  35. #include "tclInt.h"
  36.  
  37. /*
  38.  * For each linked variable there is a data structure of the following
  39.  * type, which describes the link and is the clientData for the trace
  40.  * set on the Tcl variable.
  41.  */
  42.  
  43. typedef struct Link {
  44.     Tcl_Interp *interp;        /* Interpreter containing Tcl variable. */
  45.     char *addr;            /* Location of C variable. */
  46.     int type;            /* Type of link (TCL_LINK_INT, etc.). */
  47.     int writable;        /* Zero means Tcl variable is read-only. */
  48.     union {
  49.     int i;
  50.     double d;
  51.     } lastValue;        /* Last known value of C variable;  used to
  52.                  * avoid string conversions. */
  53. } Link;
  54.  
  55. /*
  56.  * Forward references to procedures defined later in this file:
  57.  */
  58.  
  59. static char *        LinkTraceProc _ANSI_ARGS_((ClientData clientData,
  60.                 Tcl_Interp *interp, char *name1, char *name2,
  61.                 int flags));
  62. static char *        StringValue _ANSI_ARGS_((Link *linkPtr,
  63.                 char *buffer));
  64.  
  65. /*
  66.  *----------------------------------------------------------------------
  67.  *
  68.  * Tcl_LinkVar --
  69.  *
  70.  *    Link a C variable to a Tcl variable so that changes to either
  71.  *    one causes the other to change.
  72.  *
  73.  * Results:
  74.  *    The return value is TCL_OK if everything went well or TCL_ERROR
  75.  *    if an error occurred (interp->result is also set after errors).
  76.  *
  77.  * Side effects:
  78.  *    The value at *addr is linked to the Tcl variable "varName",
  79.  *    using "type" to convert between string values for Tcl and
  80.  *    binary values for *addr.
  81.  *
  82.  *----------------------------------------------------------------------
  83.  */
  84.  
  85. int
  86. Tcl_LinkVar(interp, varName, addr, type)
  87.     Tcl_Interp *interp;        /* Interpreter in which varName exists. */
  88.     char *varName;        /* Name of a global variable in interp. */
  89.     char *addr;            /* Address of a C variable to be linked
  90.                  * to varName. */
  91.     int type;            /* Type of C variable: TCL_LINK_INT, etc. 
  92.                  * Also may have TCL_LINK_READ_ONLY
  93.                  * OR'ed in. */
  94. {
  95.     Link *linkPtr;
  96.     char buffer[TCL_DOUBLE_SPACE];
  97.     int code;
  98.  
  99.     linkPtr = (Link *) ckalloc(sizeof(Link));
  100.     linkPtr->interp = interp;
  101.     linkPtr->addr = addr;
  102.     linkPtr->type = type & ~TCL_LINK_READ_ONLY;
  103.     linkPtr->writable = (type & TCL_LINK_READ_ONLY) == 0;
  104.     if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
  105.         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
  106.     ckfree((char *) linkPtr);
  107.     return TCL_ERROR;
  108.     }
  109.     code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
  110.         |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
  111.         (ClientData) linkPtr);
  112.     if (code != TCL_OK) {
  113.     ckfree((char *) linkPtr);
  114.     }
  115.     return code;
  116. }
  117.  
  118. /*
  119.  *----------------------------------------------------------------------
  120.  *
  121.  * Tcl_UnlinkVar --
  122.  *
  123.  *    Destroy the link between a Tcl variable and a C variable.
  124.  *
  125.  * Results:
  126.  *    None.
  127.  *
  128.  * Side effects:
  129.  *    If "varName" was previously linked to a C variable, the link
  130.  *    is broken to make the variable independent.  If there was no
  131.  *    previous link for "varName" then nothing happens.
  132.  *
  133.  *----------------------------------------------------------------------
  134.  */
  135.  
  136. void
  137. Tcl_UnlinkVar(interp, varName)
  138.     Tcl_Interp *interp;        /* Interpreter containing variable to unlink. */
  139.     char *varName;        /* Global variable in interp to unlink. */
  140. {
  141.     Link *linkPtr;
  142.  
  143.     linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
  144.         LinkTraceProc, (ClientData) NULL);
  145.     if (linkPtr == NULL) {
  146.     return;
  147.     }
  148.     Tcl_UntraceVar(interp, varName,
  149.         TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  150.         LinkTraceProc, (ClientData) linkPtr);
  151.     ckfree((char *) linkPtr);
  152. }
  153.  
  154. /*
  155.  *----------------------------------------------------------------------
  156.  *
  157.  * LinkTraceProc --
  158.  *
  159.  *    This procedure is invoked when a linked Tcl variable is read,
  160.  *    written, or unset from Tcl.  It's responsible for keeping the
  161.  *    C variable in sync with the Tcl variable.
  162.  *
  163.  * Results:
  164.  *    If all goes well, NULL is returned; otherwise an error message
  165.  *    is returned.
  166.  *
  167.  * Side effects:
  168.  *    The C variable may be updated to make it consistent with the
  169.  *    Tcl variable, or the Tcl variable may be overwritten to reject
  170.  *    a modification.
  171.  *
  172.  *----------------------------------------------------------------------
  173.  */
  174.  
  175. static char *
  176. LinkTraceProc(clientData, interp, name1, name2, flags)
  177.     ClientData clientData;    /* Contains information about the link. */
  178.     Tcl_Interp *interp;        /* Interpreter containing Tcl variable. */
  179.     char *name1;        /* First part of variable name. */
  180.     char *name2;        /* Second part of variable name. */
  181.     int flags;            /* Miscellaneous additional information. */
  182. {
  183.     Link *linkPtr = (Link *) clientData;
  184.     int changed;
  185.     char buffer[TCL_DOUBLE_SPACE];
  186.     char *value, **pp;
  187.     Tcl_DString savedResult;
  188.  
  189.     /*
  190.      * If the variable is being unset, then just re-create it (with a
  191.      * trace) unless the whole interpreter is going away.
  192.      */
  193.  
  194.     if (flags & TCL_TRACE_UNSETS) {
  195.     if (flags & TCL_INTERP_DESTROYED) {
  196.         ckfree((char *) linkPtr);
  197.     }
  198.     if (flags & TCL_TRACE_DESTROYED) {
  199.         Tcl_SetVar2(interp, name1, name2,
  200.             StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
  201.         Tcl_TraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY
  202.             |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  203.             LinkTraceProc, (ClientData) linkPtr);
  204.     }
  205.     return NULL;
  206.     }
  207.  
  208.     /*
  209.      * For read accesses, update the Tcl variable if the C variable
  210.      * has changed since the last time we updated the Tcl variable.
  211.      */
  212.  
  213.     if (flags & TCL_TRACE_READS) {
  214.     switch (linkPtr->type) {
  215.         case TCL_LINK_INT:
  216.         case TCL_LINK_BOOLEAN:
  217.         changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
  218.         break;
  219.         case TCL_LINK_DOUBLE:
  220.         changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
  221.         break;
  222.         case TCL_LINK_STRING:
  223.         changed = 1;
  224.         break;
  225.         default:
  226.         return "internal error: bad linked variable type";
  227.     }
  228.     if (changed) {
  229.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  230.             TCL_GLOBAL_ONLY);
  231.     }
  232.     return NULL;
  233.     }
  234.  
  235.     /*
  236.      * For writes, first make sure that the variable is writable.  Then
  237.      * convert the Tcl value to C if possible.  If the variable isn't
  238.      * writable or can't be converted, then restore the varaible's old
  239.      * value and return an error.  Another tricky thing: we have to save
  240.      * and restore the interpreter's result, since the variable access
  241.      * could occur when the result has been partially set.
  242.      */
  243.  
  244.     if (!linkPtr->writable) {
  245.     Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  246.             TCL_GLOBAL_ONLY);
  247.     return "linked variable is read-only";
  248.     }
  249.     value = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY);
  250.     if (value == NULL) {
  251.     /*
  252.      * This shouldn't ever happen.
  253.      */
  254.     return "internal error: linked variable couldn't be read";
  255.     }
  256.     Tcl_DStringInit(&savedResult);
  257.     Tcl_DStringAppend(&savedResult, interp->result, -1);
  258.     Tcl_ResetResult(interp);
  259.     switch (linkPtr->type) {
  260.     case TCL_LINK_INT:
  261.         if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
  262.         Tcl_DStringResult(interp, &savedResult);
  263.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  264.             TCL_GLOBAL_ONLY);
  265.         return "variable must have integer value";
  266.         }
  267.         *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
  268.         break;
  269.     case TCL_LINK_DOUBLE:
  270.         if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
  271.             != TCL_OK) {
  272.         Tcl_DStringResult(interp, &savedResult);
  273.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  274.             TCL_GLOBAL_ONLY);
  275.         return "variable must have real value";
  276.         }
  277.         *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
  278.         break;
  279.     case TCL_LINK_BOOLEAN:
  280.         if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
  281.             != TCL_OK) {
  282.         Tcl_DStringResult(interp, &savedResult);
  283.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  284.             TCL_GLOBAL_ONLY);
  285.         return "variable must have boolean value";
  286.         }
  287.         *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
  288.         break;
  289.     case TCL_LINK_STRING:
  290.         pp = (char **)(linkPtr->addr);
  291.         if (*pp != NULL) {
  292.         ckfree(*pp);
  293.         }
  294.         *pp = ckalloc((unsigned) (strlen(value) + 1));
  295.         strcpy(*pp, value);
  296.         break;
  297.     default:
  298.         return "internal error: bad linked variable type";
  299.     }
  300.     Tcl_DStringResult(interp, &savedResult);
  301.     return NULL;
  302. }
  303.  
  304. /*
  305.  *----------------------------------------------------------------------
  306.  *
  307.  * StringValue --
  308.  *
  309.  *    Converts the value of a C variable to a string for use in a
  310.  *    Tcl variable to which it is linked.
  311.  *
  312.  * Results:
  313.  *    The return value is a pointer
  314.  to a string that represents
  315.  *    the value of the C variable given by linkPtr.
  316.  *
  317.  * Side effects:
  318.  *    None.
  319.  *
  320.  *----------------------------------------------------------------------
  321.  */
  322.  
  323. static char *
  324. StringValue(linkPtr, buffer)
  325.     Link *linkPtr;        /* Structure describing linked variable. */
  326.     char *buffer;        /* Small buffer to use for converting
  327.                  * values.  Must have TCL_DOUBLE_SPACE
  328.                  * bytes or more. */
  329. {
  330.     char *p;
  331.  
  332.     switch (linkPtr->type) {
  333.     case TCL_LINK_INT:
  334.         linkPtr->lastValue.i = *(int *)(linkPtr->addr);
  335.         sprintf(buffer, "%d", linkPtr->lastValue.i);
  336.         return buffer;
  337.     case TCL_LINK_DOUBLE:
  338.         linkPtr->lastValue.d = *(double *)(linkPtr->addr);
  339.         Tcl_PrintDouble(linkPtr->interp, linkPtr->lastValue.d, buffer);
  340.         return buffer;
  341.     case TCL_LINK_BOOLEAN:
  342.         linkPtr->lastValue.i = *(int *)(linkPtr->addr);
  343.         if (linkPtr->lastValue.i != 0) {
  344.         return "1";
  345.         }
  346.         return "0";
  347.     case TCL_LINK_STRING:
  348.         p = *(char **)(linkPtr->addr);
  349.         if (p == NULL) {
  350.         return "NULL";
  351.         }
  352.         return p;
  353.     }
  354.  
  355.     /*
  356.      * This code only gets executed if the link type is unknown
  357.      * (shouldn't ever happen).
  358.      */
  359.  
  360.     return "??";
  361. }
  362.