util/src/TclTk/tcl8.6.12/generic/tclLink.c

   1 /*
   2  * tclLink.c --
   3  *
   4  *      This file implements linked variables (a C variable that is tied to a
   5  *      Tcl variable). The idea of linked variables was first suggested by
   6  *      Andreas Stolcke and this implementation is based heavily on a
   7  *      prototype implementation provided by him.
   8  *
   9  * Copyright (c) 1993 The Regents of the University of California.
  10  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11  *
  12  * See the file "license.terms" for information on usage and redistribution of
  13  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14  */
  15
  16 #include "tclInt.h"
  17
  18 /*
  19  * For each linked variable there is a data structure of the following type,
  20  * which describes the link and is the clientData for the trace set on the Tcl
  21  * variable.
  22  */
  23
  24 typedef struct Link {
  25     Tcl_Interp *interp;         /* Interpreter containing Tcl variable. */
  26     Namespace *nsPtr;           /* Namespace containing Tcl variable */
  27     Tcl_Obj *varName;           /* Name of variable (must be global). This is
  28                                  * needed during trace callbacks, since the
  29                                  * actual variable may be aliased at that time
  30                                  * via upvar. */
  31     char *addr;                 /* Location of C variable. */
  32     int type;                   /* Type of link (TCL_LINK_INT, etc.). */
  33     union {
  34         char c;
  35         unsigned char uc;
  36         int i;
  37         unsigned int ui;
  38         short s;
  39         unsigned short us;
  40         long l;
  41         unsigned long ul;
  42         Tcl_WideInt w;
  43         Tcl_WideUInt uw;
  44         float f;
  45         double d;
  46     } lastValue;                /* Last known value of C variable; used to
  47                                  * avoid string conversions. */
  48     int flags;                  /* Miscellaneous one-bit values; see below for
  49                                  * definitions. */
  50 } Link;
  51
  52 /*
  53  * Definitions for flag bits:
  54  * LINK_READ_ONLY -             1 means errors should be generated if Tcl
  55  *                              script attempts to write variable.
  56  * LINK_BEING_UPDATED -         1 means that a call to Tcl_UpdateLinkedVar is
  57  *                              in progress for this variable, so trace
  58  *                              callbacks on the variable should be ignored.
  59  */
  60
  61 #define LINK_READ_ONLY          1
  62 #define LINK_BEING_UPDATED      2
  63
  64 /*
  65  * Forward references to functions defined later in this file:
  66  */
  67
  68 static char *           LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
  69                             const char *name1, const char *name2, int flags);
  70 static Tcl_Obj *        ObjValue(Link *linkPtr);
  71 static int              GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
  72 static int              GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr);
  73 static int              GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr);
  74
  75 /*
  76  * Convenience macro for accessing the value of the C variable pointed to by a
  77  * link. Note that this macro produces something that may be regarded as an
  78  * lvalue or rvalue; it may be assigned to as well as read. Also note that
  79  * this macro assumes the name of the variable being accessed (linkPtr); this
  80  * is not strictly a good thing, but it keeps the code much shorter and
  81  * cleaner.
  82  */
  83
  84 #define LinkedVar(type) (*(type *) linkPtr->addr)
  85 \f
  86 /*
  87  *----------------------------------------------------------------------
  88  *
  89  * Tcl_LinkVar --
  90  *
  91  *      Link a C variable to a Tcl variable so that changes to either one
  92  *      causes the other to change.
  93  *
  94  * Results:
  95  *      The return value is TCL_OK if everything went well or TCL_ERROR if an
  96  *      error occurred (the interp's result is also set after errors).
  97  *
  98  * Side effects:
  99  *      The value at *addr is linked to the Tcl variable "varName", using
 100  *      "type" to convert between string values for Tcl and binary values for
 101  *      *addr.
 102  *
 103  *----------------------------------------------------------------------
 104  */
 105
 106 int
 107 Tcl_LinkVar(
 108     Tcl_Interp *interp,         /* Interpreter in which varName exists. */
 109     const char *varName,        /* Name of a global variable in interp. */
 110     char *addr,                 /* Address of a C variable to be linked to
 111                                  * varName. */
 112     int type)                   /* Type of C variable: TCL_LINK_INT, etc. Also
 113                                  * may have TCL_LINK_READ_ONLY OR'ed in. */
 114 {
 115     Tcl_Obj *objPtr;
 116     Link *linkPtr;
 117     Namespace *dummy;
 118     const char *name;
 119     int code;
 120
 121     linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
 122             TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
 123     if (linkPtr != NULL) {
 124         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 125                 "variable '%s' is already linked", varName));
 126         return TCL_ERROR;
 127     }
 128
 129     linkPtr = ckalloc(sizeof(Link));
 130     linkPtr->interp = interp;
 131     linkPtr->nsPtr = NULL;
 132     linkPtr->varName = Tcl_NewStringObj(varName, -1);
 133     Tcl_IncrRefCount(linkPtr->varName);
 134     linkPtr->addr = addr;
 135     linkPtr->type = type & ~TCL_LINK_READ_ONLY;
 136     if (type & TCL_LINK_READ_ONLY) {
 137         linkPtr->flags = LINK_READ_ONLY;
 138     } else {
 139         linkPtr->flags = 0;
 140     }
 141     objPtr = ObjValue(linkPtr);
 142     if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
 143             TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
 144         Tcl_DecrRefCount(linkPtr->varName);
 145         ckfree(linkPtr);
 146         return TCL_ERROR;
 147     }
 148
 149     TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
 150             &(linkPtr->nsPtr), &dummy, &dummy, &name);
 151     linkPtr->nsPtr->refCount++;
 152
 153     code = Tcl_TraceVar2(interp, varName, NULL,
 154             TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 155             LinkTraceProc, linkPtr);
 156     if (code != TCL_OK) {
 157         Tcl_DecrRefCount(linkPtr->varName);
 158         TclNsDecrRefCount(linkPtr->nsPtr);
 159         ckfree(linkPtr);
 160     }
 161     return code;
 162 }
 163 \f
 164 /*
 165  *----------------------------------------------------------------------
 166  *
 167  * Tcl_UnlinkVar --
 168  *
 169  *      Destroy the link between a Tcl variable and a C variable.
 170  *
 171  * Results:
 172  *      None.
 173  *
 174  * Side effects:
 175  *      If "varName" was previously linked to a C variable, the link is broken
 176  *      to make the variable independent. If there was no previous link for
 177  *      "varName" then nothing happens.
 178  *
 179  *----------------------------------------------------------------------
 180  */
 181
 182 void
 183 Tcl_UnlinkVar(
 184     Tcl_Interp *interp,         /* Interpreter containing variable to unlink */
 185     const char *varName)        /* Global variable in interp to unlink. */
 186 {
 187     Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
 188             TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
 189
 190     if (linkPtr == NULL) {
 191         return;
 192     }
 193     Tcl_UntraceVar2(interp, varName, NULL,
 194             TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 195             LinkTraceProc, linkPtr);
 196     Tcl_DecrRefCount(linkPtr->varName);
 197     if (linkPtr->nsPtr) {
 198         TclNsDecrRefCount(linkPtr->nsPtr);
 199     }
 200     ckfree(linkPtr);
 201 }
 202 \f
 203 /*
 204  *----------------------------------------------------------------------
 205  *
 206  * Tcl_UpdateLinkedVar --
 207  *
 208  *      This function is invoked after a linked variable has been changed by C
 209  *      code. It updates the Tcl variable so that traces on the variable will
 210  *      trigger.
 211  *
 212  * Results:
 213  *      None.
 214  *
 215  * Side effects:
 216  *      The Tcl variable "varName" is updated from its C value, causing traces
 217  *      on the variable to trigger.
 218  *
 219  *----------------------------------------------------------------------
 220  */
 221
 222 void
 223 Tcl_UpdateLinkedVar(
 224     Tcl_Interp *interp,         /* Interpreter containing variable. */
 225     const char *varName)        /* Name of global variable that is linked. */
 226 {
 227     Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
 228             TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
 229     int savedFlag;
 230
 231     if (linkPtr == NULL) {
 232         return;
 233     }
 234     savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
 235     linkPtr->flags |= LINK_BEING_UPDATED;
 236     Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 237             TCL_GLOBAL_ONLY);
 238     /*
 239      * Callback may have unlinked the variable. [Bug 1740631]
 240      */
 241     linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
 242             TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
 243     if (linkPtr != NULL) {
 244         linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
 245     }
 246 }
 247 \f
 248 /*
 249  *----------------------------------------------------------------------
 250  *
 251  * LinkTraceProc --
 252  *
 253  *      This function is invoked when a linked Tcl variable is read, written,
 254  *      or unset from Tcl. It's responsible for keeping the C variable in sync
 255  *      with the Tcl variable.
 256  *
 257  * Results:
 258  *      If all goes well, NULL is returned; otherwise an error message is
 259  *      returned.
 260  *
 261  * Side effects:
 262  *      The C variable may be updated to make it consistent with the Tcl
 263  *      variable, or the Tcl variable may be overwritten to reject a
 264  *      modification.
 265  *
 266  *----------------------------------------------------------------------
 267  */
 268
 269 static char *
 270 LinkTraceProc(
 271     ClientData clientData,      /* Contains information about the link. */
 272     Tcl_Interp *interp,         /* Interpreter containing Tcl variable. */
 273     const char *name1,          /* First part of variable name. */
 274     const char *name2,          /* Second part of variable name. */
 275     int flags)                  /* Miscellaneous additional information. */
 276 {
 277     Link *linkPtr = clientData;
 278     int changed;
 279     size_t valueLength;
 280     const char *value;
 281     char **pp;
 282     Tcl_Obj *valueObj;
 283     int valueInt;
 284     Tcl_WideInt valueWide;
 285     double valueDouble;
 286
 287     /*
 288      * If the variable is being unset, then just re-create it (with a trace)
 289      * unless the whole interpreter is going away.
 290      */
 291
 292     if (flags & TCL_TRACE_UNSETS) {
 293         if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
 294             Tcl_DecrRefCount(linkPtr->varName);
 295             if (linkPtr->nsPtr) {
 296                 TclNsDecrRefCount(linkPtr->nsPtr);
 297             }
 298             ckfree(linkPtr);
 299         } else if (flags & TCL_TRACE_DESTROYED) {
 300             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 301                     TCL_GLOBAL_ONLY);
 302             Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL,
 303                     TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
 304                     |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
 305         }
 306         return NULL;
 307     }
 308
 309     /*
 310      * If we were invoked because of a call to Tcl_UpdateLinkedVar, then don't
 311      * do anything at all. In particular, we don't want to get upset that the
 312      * variable is being modified, even if it is supposed to be read-only.
 313      */
 314
 315     if (linkPtr->flags & LINK_BEING_UPDATED) {
 316         return NULL;
 317     }
 318
 319     /*
 320      * For read accesses, update the Tcl variable if the C variable has
 321      * changed since the last time we updated the Tcl variable.
 322      */
 323
 324     if (flags & TCL_TRACE_READS) {
 325         switch (linkPtr->type) {
 326         case TCL_LINK_INT:
 327         case TCL_LINK_BOOLEAN:
 328             changed = (LinkedVar(int) != linkPtr->lastValue.i);
 329             break;
 330         case TCL_LINK_DOUBLE:
 331             changed = (LinkedVar(double) != linkPtr->lastValue.d);
 332             break;
 333         case TCL_LINK_WIDE_INT:
 334             changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
 335             break;
 336         case TCL_LINK_WIDE_UINT:
 337             changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
 338             break;
 339         case TCL_LINK_CHAR:
 340             changed = (LinkedVar(char) != linkPtr->lastValue.c);
 341             break;
 342         case TCL_LINK_UCHAR:
 343             changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
 344             break;
 345         case TCL_LINK_SHORT:
 346             changed = (LinkedVar(short) != linkPtr->lastValue.s);
 347             break;
 348         case TCL_LINK_USHORT:
 349             changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
 350             break;
 351         case TCL_LINK_UINT:
 352             changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
 353             break;
 354         case TCL_LINK_LONG:
 355             changed = (LinkedVar(long) != linkPtr->lastValue.l);
 356             break;
 357         case TCL_LINK_ULONG:
 358             changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
 359             break;
 360         case TCL_LINK_FLOAT:
 361             changed = (LinkedVar(float) != linkPtr->lastValue.f);
 362             break;
 363         case TCL_LINK_STRING:
 364             changed = 1;
 365             break;
 366         default:
 367             return (char *) "internal error: bad linked variable type";
 368         }
 369         if (changed) {
 370             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 371                     TCL_GLOBAL_ONLY);
 372         }
 373         return NULL;
 374     }
 375
 376     /*
 377      * For writes, first make sure that the variable is writable. Then convert
 378      * the Tcl value to C if possible. If the variable isn't writable or can't
 379      * be converted, then restore the varaible's old value and return an
 380      * error. Another tricky thing: we have to save and restore the interp's
 381      * result, since the variable access could occur when the result has been
 382      * partially set.
 383      */
 384
 385     if (linkPtr->flags & LINK_READ_ONLY) {
 386         Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 387                 TCL_GLOBAL_ONLY);
 388         return (char *) "linked variable is read-only";
 389     }
 390     valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
 391     if (valueObj == NULL) {
 392         /*
 393          * This shouldn't ever happen.
 394          */
 395
 396         return (char *) "internal error: linked variable couldn't be read";
 397     }
 398
 399     switch (linkPtr->type) {
 400     case TCL_LINK_INT:
 401         if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK
 402                 && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) {
 403             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 404                     TCL_GLOBAL_ONLY);
 405             return (char *) "variable must have integer value";
 406         }
 407         LinkedVar(int) = linkPtr->lastValue.i;
 408         break;
 409
 410     case TCL_LINK_WIDE_INT:
 411         if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK
 412                 && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) {
 413             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 414                     TCL_GLOBAL_ONLY);
 415             return (char *) "variable must have integer value";
 416         }
 417         LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
 418         break;
 419
 420     case TCL_LINK_DOUBLE:
 421         if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) {
 422 #ifdef ACCEPT_NAN
 423             if (valueObj->typePtr != &tclDoubleType) {
 424 #endif
 425                 if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
 426                     Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 427                         TCL_GLOBAL_ONLY);
 428                     return (char *) "variable must have real value";
 429                 }
 430 #ifdef ACCEPT_NAN
 431             }
 432             linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
 433 #endif
 434         }
 435         LinkedVar(double) = linkPtr->lastValue.d;
 436         break;
 437
 438     case TCL_LINK_BOOLEAN:
 439         if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) {
 440             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 441                     TCL_GLOBAL_ONLY);
 442             return (char *) "variable must have boolean value";
 443         }
 444         LinkedVar(int) = linkPtr->lastValue.i;
 445         break;
 446
 447     case TCL_LINK_CHAR:
 448         if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
 449                 && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
 450                 || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
 451             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 452                     TCL_GLOBAL_ONLY);
 453             return (char *) "variable must have char value";
 454         }
 455         LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt;
 456         break;
 457
 458     case TCL_LINK_UCHAR:
 459         if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
 460                 && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
 461                 || valueInt < 0 || valueInt > UCHAR_MAX) {
 462             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 463                     TCL_GLOBAL_ONLY);
 464             return (char *) "variable must have unsigned char value";
 465         }
 466         LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt;
 467         break;
 468
 469     case TCL_LINK_SHORT:
 470         if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
 471                 && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
 472                 || valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
 473             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 474                     TCL_GLOBAL_ONLY);
 475             return (char *) "variable must have short value";
 476         }
 477         LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt;
 478         break;
 479
 480     case TCL_LINK_USHORT:
 481         if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
 482                 && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
 483                 || valueInt < 0 || valueInt > USHRT_MAX) {
 484             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 485                     TCL_GLOBAL_ONLY);
 486             return (char *) "variable must have unsigned short value";
 487         }
 488         LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt;
 489         break;
 490
 491     case TCL_LINK_UINT:
 492         if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
 493                 && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
 494                 || valueWide < 0 || valueWide > UINT_MAX) {
 495             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 496                     TCL_GLOBAL_ONLY);
 497             return (char *) "variable must have unsigned int value";
 498         }
 499         LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide;
 500         break;
 501
 502     case TCL_LINK_LONG:
 503         if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
 504                 && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
 505                 || valueWide < LONG_MIN || valueWide > LONG_MAX) {
 506             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 507                     TCL_GLOBAL_ONLY);
 508             return (char *) "variable must have long value";
 509         }
 510         LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide;
 511         break;
 512
 513     case TCL_LINK_ULONG:
 514         if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
 515                 && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
 516                 || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
 517             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 518                     TCL_GLOBAL_ONLY);
 519             return (char *) "variable must have unsigned long value";
 520         }
 521         LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide;
 522         break;
 523
 524     case TCL_LINK_WIDE_UINT:
 525         /*
 526          * FIXME: represent as a bignum.
 527          */
 528         if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
 529                 && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
 530             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 531                     TCL_GLOBAL_ONLY);
 532             return (char *) "variable must have unsigned wide int value";
 533         }
 534         LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
 535         break;
 536
 537     case TCL_LINK_FLOAT:
 538         if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
 539                 && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK)
 540                 || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
 541             Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 542                     TCL_GLOBAL_ONLY);
 543             return (char *) "variable must have float value";
 544         }
 545         LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble;
 546         break;
 547
 548     case TCL_LINK_STRING:
 549         value = TclGetString(valueObj);
 550         valueLength = valueObj->length + 1;
 551         pp = (char **) linkPtr->addr;
 552
 553         *pp = ckrealloc(*pp, valueLength);
 554         memcpy(*pp, value, valueLength);
 555         break;
 556
 557     default:
 558         return (char *) "internal error: bad linked variable type";
 559     }
 560     return NULL;
 561 }
 562 \f
 563 /*
 564  *----------------------------------------------------------------------
 565  *
 566  * ObjValue --
 567  *
 568  *      Converts the value of a C variable to a Tcl_Obj* for use in a Tcl
 569  *      variable to which it is linked.
 570  *
 571  * Results:
 572  *      The return value is a pointer to a Tcl_Obj that represents the value
 573  *      of the C variable given by linkPtr.
 574  *
 575  * Side effects:
 576  *      None.
 577  *
 578  *----------------------------------------------------------------------
 579  */
 580
 581 static Tcl_Obj *
 582 ObjValue(
 583     Link *linkPtr)              /* Structure describing linked variable. */
 584 {
 585     char *p;
 586     Tcl_Obj *resultObj;
 587
 588     switch (linkPtr->type) {
 589     case TCL_LINK_INT:
 590         linkPtr->lastValue.i = LinkedVar(int);
 591         return Tcl_NewIntObj(linkPtr->lastValue.i);
 592     case TCL_LINK_WIDE_INT:
 593         linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
 594         return Tcl_NewWideIntObj(linkPtr->lastValue.w);
 595     case TCL_LINK_DOUBLE:
 596         linkPtr->lastValue.d = LinkedVar(double);
 597         return Tcl_NewDoubleObj(linkPtr->lastValue.d);
 598     case TCL_LINK_BOOLEAN:
 599         linkPtr->lastValue.i = LinkedVar(int);
 600         return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
 601     case TCL_LINK_CHAR:
 602         linkPtr->lastValue.c = LinkedVar(char);
 603         return Tcl_NewIntObj(linkPtr->lastValue.c);
 604     case TCL_LINK_UCHAR:
 605         linkPtr->lastValue.uc = LinkedVar(unsigned char);
 606         return Tcl_NewIntObj(linkPtr->lastValue.uc);
 607     case TCL_LINK_SHORT:
 608         linkPtr->lastValue.s = LinkedVar(short);
 609         return Tcl_NewIntObj(linkPtr->lastValue.s);
 610     case TCL_LINK_USHORT:
 611         linkPtr->lastValue.us = LinkedVar(unsigned short);
 612         return Tcl_NewIntObj(linkPtr->lastValue.us);
 613     case TCL_LINK_UINT:
 614         linkPtr->lastValue.ui = LinkedVar(unsigned int);
 615         return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
 616     case TCL_LINK_LONG:
 617         linkPtr->lastValue.l = LinkedVar(long);
 618         return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
 619     case TCL_LINK_ULONG:
 620         linkPtr->lastValue.ul = LinkedVar(unsigned long);
 621         return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
 622     case TCL_LINK_FLOAT:
 623         linkPtr->lastValue.f = LinkedVar(float);
 624         return Tcl_NewDoubleObj(linkPtr->lastValue.f);
 625     case TCL_LINK_WIDE_UINT:
 626         linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
 627         /*
 628          * FIXME: represent as a bignum.
 629          */
 630         return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
 631     case TCL_LINK_STRING:
 632         p = LinkedVar(char *);
 633         if (p == NULL) {
 634             TclNewLiteralStringObj(resultObj, "NULL");
 635             return resultObj;
 636         }
 637         return Tcl_NewStringObj(p, -1);
 638
 639     /*
 640      * This code only gets executed if the link type is unknown (shouldn't
 641      * ever happen).
 642      */
 643
 644     default:
 645         TclNewLiteralStringObj(resultObj, "??");
 646         return resultObj;
 647     }
 648 }
 649
 650 static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 651
 652 static Tcl_ObjType invalidRealType = {
 653     "invalidReal",                      /* name */
 654     NULL,                               /* freeIntRepProc */
 655     NULL,                               /* dupIntRepProc */
 656     NULL,                               /* updateStringProc */
 657     NULL                                /* setFromAnyProc */
 658 };
 659
 660 static int
 661 SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
 662     int length;
 663     const char *str;
 664     const char *endPtr;
 665
 666     str = TclGetStringFromObj(objPtr, &length);
 667     if ((length == 1) && (str[0] == '.')){
 668         objPtr->typePtr = &invalidRealType;
 669         objPtr->internalRep.doubleValue = 0.0;
 670         return TCL_OK;
 671     }
 672     if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
 673             TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
 674         /* If number is followed by [eE][+-]?, then it is an invalid
 675          * double, but it could be the start of a valid double. */
 676         if (*endPtr == 'e' || *endPtr == 'E') {
 677             ++endPtr;
 678             if (*endPtr == '+' || *endPtr == '-') ++endPtr;
 679             if (*endPtr == 0) {
 680                 double doubleValue = 0.0;
 681                 Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
 682                 if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr);
 683                 objPtr->typePtr = &invalidRealType;
 684                 objPtr->internalRep.doubleValue = doubleValue;
 685                 return TCL_OK;
 686             }
 687         }
 688     }
 689     return TCL_ERROR;
 690 }
 691
 692
 693 /*
 694  * This function checks for integer representations, which are valid
 695  * when linking with C variables, but which are invalid in other
 696  * contexts in Tcl. Handled are "+", "-", "", "0x", "0b" and "0o"
 697  * (upperand lowercase). See bug [39f6304c2e].
 698  */
 699 int
 700 GetInvalidIntFromObj(Tcl_Obj *objPtr,
 701                                 int *intPtr)
 702 {
 703     const char *str = TclGetString(objPtr);
 704
 705     if ((objPtr->length == 0) ||
 706             ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) {
 707         *intPtr = 0;
 708         return TCL_OK;
 709     } else if ((objPtr->length == 1) && strchr("+-", str[0])) {
 710         *intPtr = (str[0] == '+');
 711         return TCL_OK;
 712     }
 713     return TCL_ERROR;
 714 }
 715
 716 int
 717 GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr)
 718 {
 719     int intValue;
 720
 721     if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
 722         return TCL_ERROR;
 723     }
 724     *widePtr = intValue;
 725     return TCL_OK;
 726 }
 727
 728 /*
 729  * This function checks for double representations, which are valid
 730  * when linking with C variables, but which are invalid in other
 731  * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
 732  * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
 733  */
 734 int
 735 GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
 736                                 double *doublePtr)
 737 {
 738     int intValue;
 739
 740     if (objPtr->typePtr == &invalidRealType) {
 741         goto gotdouble;
 742     }
 743     if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
 744         *doublePtr = (double) intValue;
 745         return TCL_OK;
 746     }
 747     if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
 748     gotdouble:
 749         *doublePtr = objPtr->internalRep.doubleValue;
 750         return TCL_OK;
 751     }
 752     return TCL_ERROR;
 753 }
 754 \f
 755 /*
 756  * Local Variables:
 757  * mode: c
 758  * c-basic-offset: 4
 759  * fill-column: 78
 760  * End:
 761  */