os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclLink.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclLink.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,475 @@
1.4 +/*
1.5 + * tclLink.c --
1.6 + *
1.7 + * This file implements linked variables (a C variable that is
1.8 + * tied to a Tcl variable). The idea of linked variables was
1.9 + * first suggested by Andreas Stolcke and this implementation is
1.10 + * based heavily on a prototype implementation provided by
1.11 + * him.
1.12 + *
1.13 + * Copyright (c) 1993 The Regents of the University of California.
1.14 + * Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.15 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.16 + *
1.17 + * See the file "license.terms" for information on usage and redistribution
1.18 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.19 + *
1.20 + * RCS: @(#) $Id: tclLink.c,v 1.8.2.2 2007/05/10 18:23:58 dgp Exp $
1.21 + */
1.22 +
1.23 +#include "tclInt.h"
1.24 +
1.25 +/*
1.26 + * For each linked variable there is a data structure of the following
1.27 + * type, which describes the link and is the clientData for the trace
1.28 + * set on the Tcl variable.
1.29 + */
1.30 +
1.31 +typedef struct Link {
1.32 + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
1.33 + Tcl_Obj *varName; /* Name of variable (must be global). This
1.34 + * is needed during trace callbacks, since
1.35 + * the actual variable may be aliased at
1.36 + * that time via upvar. */
1.37 + char *addr; /* Location of C variable. */
1.38 + int type; /* Type of link (TCL_LINK_INT, etc.). */
1.39 + union {
1.40 + int i;
1.41 + double d;
1.42 + Tcl_WideInt w;
1.43 + } lastValue; /* Last known value of C variable; used to
1.44 + * avoid string conversions. */
1.45 + int flags; /* Miscellaneous one-bit values; see below
1.46 + * for definitions. */
1.47 +} Link;
1.48 +
1.49 +/*
1.50 + * Definitions for flag bits:
1.51 + * LINK_READ_ONLY - 1 means errors should be generated if Tcl
1.52 + * script attempts to write variable.
1.53 + * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar
1.54 + * is in progress for this variable, so
1.55 + * trace callbacks on the variable should
1.56 + * be ignored.
1.57 + */
1.58 +
1.59 +#define LINK_READ_ONLY 1
1.60 +#define LINK_BEING_UPDATED 2
1.61 +
1.62 +/*
1.63 + * Forward references to procedures defined later in this file:
1.64 + */
1.65 +
1.66 +static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData,
1.67 + Tcl_Interp *interp, CONST char *name1,
1.68 + CONST char *name2, int flags));
1.69 +static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr));
1.70 +
1.71 +/*
1.72 + *----------------------------------------------------------------------
1.73 + *
1.74 + * Tcl_LinkVar --
1.75 + *
1.76 + * Link a C variable to a Tcl variable so that changes to either
1.77 + * one causes the other to change.
1.78 + *
1.79 + * Results:
1.80 + * The return value is TCL_OK if everything went well or TCL_ERROR
1.81 + * if an error occurred (the interp's result is also set after
1.82 + * errors).
1.83 + *
1.84 + * Side effects:
1.85 + * The value at *addr is linked to the Tcl variable "varName",
1.86 + * using "type" to convert between string values for Tcl and
1.87 + * binary values for *addr.
1.88 + *
1.89 + *----------------------------------------------------------------------
1.90 + */
1.91 +
1.92 +EXPORT_C int
1.93 +Tcl_LinkVar(interp, varName, addr, type)
1.94 + Tcl_Interp *interp; /* Interpreter in which varName exists. */
1.95 + CONST char *varName; /* Name of a global variable in interp. */
1.96 + char *addr; /* Address of a C variable to be linked
1.97 + * to varName. */
1.98 + int type; /* Type of C variable: TCL_LINK_INT, etc.
1.99 + * Also may have TCL_LINK_READ_ONLY
1.100 + * OR'ed in. */
1.101 +{
1.102 + Tcl_Obj *objPtr, *resPtr;
1.103 + Link *linkPtr;
1.104 + int code;
1.105 +
1.106 + linkPtr = (Link *) ckalloc(sizeof(Link));
1.107 + linkPtr->interp = interp;
1.108 + linkPtr->varName = Tcl_NewStringObj(varName, -1);
1.109 + Tcl_IncrRefCount(linkPtr->varName);
1.110 + linkPtr->addr = addr;
1.111 + linkPtr->type = type & ~TCL_LINK_READ_ONLY;
1.112 + if (type & TCL_LINK_READ_ONLY) {
1.113 + linkPtr->flags = LINK_READ_ONLY;
1.114 + } else {
1.115 + linkPtr->flags = 0;
1.116 + }
1.117 + objPtr = ObjValue(linkPtr);
1.118 + Tcl_IncrRefCount(objPtr);
1.119 + resPtr = Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
1.120 + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
1.121 + Tcl_DecrRefCount(objPtr);
1.122 + if (resPtr == NULL) {
1.123 + Tcl_DecrRefCount(linkPtr->varName);
1.124 + ckfree((char *) linkPtr);
1.125 + return TCL_ERROR;
1.126 + }
1.127 + code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
1.128 + |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
1.129 + (ClientData) linkPtr);
1.130 + if (code != TCL_OK) {
1.131 + Tcl_DecrRefCount(linkPtr->varName);
1.132 + ckfree((char *) linkPtr);
1.133 + }
1.134 + return code;
1.135 +}
1.136 +
1.137 +/*
1.138 + *----------------------------------------------------------------------
1.139 + *
1.140 + * Tcl_UnlinkVar --
1.141 + *
1.142 + * Destroy the link between a Tcl variable and a C variable.
1.143 + *
1.144 + * Results:
1.145 + * None.
1.146 + *
1.147 + * Side effects:
1.148 + * If "varName" was previously linked to a C variable, the link
1.149 + * is broken to make the variable independent. If there was no
1.150 + * previous link for "varName" then nothing happens.
1.151 + *
1.152 + *----------------------------------------------------------------------
1.153 + */
1.154 +
1.155 +EXPORT_C void
1.156 +Tcl_UnlinkVar(interp, varName)
1.157 + Tcl_Interp *interp; /* Interpreter containing variable to unlink. */
1.158 + CONST char *varName; /* Global variable in interp to unlink. */
1.159 +{
1.160 + Link *linkPtr;
1.161 +
1.162 + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
1.163 + LinkTraceProc, (ClientData) NULL);
1.164 + if (linkPtr == NULL) {
1.165 + return;
1.166 + }
1.167 + Tcl_UntraceVar(interp, varName,
1.168 + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
1.169 + LinkTraceProc, (ClientData) linkPtr);
1.170 + Tcl_DecrRefCount(linkPtr->varName);
1.171 + ckfree((char *) linkPtr);
1.172 +}
1.173 +
1.174 +/*
1.175 + *----------------------------------------------------------------------
1.176 + *
1.177 + * Tcl_UpdateLinkedVar --
1.178 + *
1.179 + * This procedure is invoked after a linked variable has been
1.180 + * changed by C code. It updates the Tcl variable so that
1.181 + * traces on the variable will trigger.
1.182 + *
1.183 + * Results:
1.184 + * None.
1.185 + *
1.186 + * Side effects:
1.187 + * The Tcl variable "varName" is updated from its C value,
1.188 + * causing traces on the variable to trigger.
1.189 + *
1.190 + *----------------------------------------------------------------------
1.191 + */
1.192 +
1.193 +EXPORT_C void
1.194 +Tcl_UpdateLinkedVar(interp, varName)
1.195 + Tcl_Interp *interp; /* Interpreter containing variable. */
1.196 + CONST char *varName; /* Name of global variable that is linked. */
1.197 +{
1.198 + Link *linkPtr;
1.199 + int savedFlag;
1.200 + Tcl_Obj *objPtr;
1.201 +
1.202 + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
1.203 + LinkTraceProc, (ClientData) NULL);
1.204 + if (linkPtr == NULL) {
1.205 + return;
1.206 + }
1.207 + savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
1.208 + linkPtr->flags |= LINK_BEING_UPDATED;
1.209 + objPtr = ObjValue(linkPtr);
1.210 + Tcl_IncrRefCount(objPtr);
1.211 + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY);
1.212 + Tcl_DecrRefCount(objPtr);
1.213 + linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
1.214 +}
1.215 +
1.216 +/*
1.217 + *----------------------------------------------------------------------
1.218 + *
1.219 + * LinkTraceProc --
1.220 + *
1.221 + * This procedure is invoked when a linked Tcl variable is read,
1.222 + * written, or unset from Tcl. It's responsible for keeping the
1.223 + * C variable in sync with the Tcl variable.
1.224 + *
1.225 + * Results:
1.226 + * If all goes well, NULL is returned; otherwise an error message
1.227 + * is returned.
1.228 + *
1.229 + * Side effects:
1.230 + * The C variable may be updated to make it consistent with the
1.231 + * Tcl variable, or the Tcl variable may be overwritten to reject
1.232 + * a modification.
1.233 + *
1.234 + *----------------------------------------------------------------------
1.235 + */
1.236 +
1.237 +static char *
1.238 +LinkTraceProc(clientData, interp, name1, name2, flags)
1.239 + ClientData clientData; /* Contains information about the link. */
1.240 + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
1.241 + CONST char *name1; /* First part of variable name. */
1.242 + CONST char *name2; /* Second part of variable name. */
1.243 + int flags; /* Miscellaneous additional information. */
1.244 +{
1.245 + Link *linkPtr = (Link *) clientData;
1.246 + int changed, valueLength;
1.247 + CONST char *value;
1.248 + char **pp, *result;
1.249 + Tcl_Obj *objPtr, *valueObj, *tmpPtr;
1.250 +
1.251 + /*
1.252 + * If the variable is being unset, then just re-create it (with a
1.253 + * trace) unless the whole interpreter is going away.
1.254 + */
1.255 +
1.256 + if (flags & TCL_TRACE_UNSETS) {
1.257 + if (Tcl_InterpDeleted(interp)) {
1.258 + Tcl_DecrRefCount(linkPtr->varName);
1.259 + ckfree((char *) linkPtr);
1.260 + } else if (flags & TCL_TRACE_DESTROYED) {
1.261 + tmpPtr = ObjValue(linkPtr);
1.262 + Tcl_IncrRefCount(tmpPtr);
1.263 + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
1.264 + TCL_GLOBAL_ONLY);
1.265 + Tcl_DecrRefCount(tmpPtr);
1.266 + Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
1.267 + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
1.268 + |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
1.269 + }
1.270 + return NULL;
1.271 + }
1.272 +
1.273 + /*
1.274 + * If we were invoked because of a call to Tcl_UpdateLinkedVar, then
1.275 + * don't do anything at all. In particular, we don't want to get
1.276 + * upset that the variable is being modified, even if it is
1.277 + * supposed to be read-only.
1.278 + */
1.279 +
1.280 + if (linkPtr->flags & LINK_BEING_UPDATED) {
1.281 + return NULL;
1.282 + }
1.283 +
1.284 + /*
1.285 + * For read accesses, update the Tcl variable if the C variable
1.286 + * has changed since the last time we updated the Tcl variable.
1.287 + */
1.288 +
1.289 + if (flags & TCL_TRACE_READS) {
1.290 + switch (linkPtr->type) {
1.291 + case TCL_LINK_INT:
1.292 + case TCL_LINK_BOOLEAN:
1.293 + changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
1.294 + break;
1.295 + case TCL_LINK_DOUBLE:
1.296 + changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
1.297 + break;
1.298 + case TCL_LINK_WIDE_INT:
1.299 + changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w;
1.300 + break;
1.301 + case TCL_LINK_STRING:
1.302 + changed = 1;
1.303 + break;
1.304 + default:
1.305 + return "internal error: bad linked variable type";
1.306 + }
1.307 + if (changed) {
1.308 + tmpPtr = ObjValue(linkPtr);
1.309 + Tcl_IncrRefCount(tmpPtr);
1.310 + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
1.311 + TCL_GLOBAL_ONLY);
1.312 + Tcl_DecrRefCount(tmpPtr);
1.313 + }
1.314 + return NULL;
1.315 + }
1.316 +
1.317 + /*
1.318 + * For writes, first make sure that the variable is writable. Then
1.319 + * convert the Tcl value to C if possible. If the variable isn't
1.320 + * writable or can't be converted, then restore the varaible's old
1.321 + * value and return an error. Another tricky thing: we have to save
1.322 + * and restore the interpreter's result, since the variable access
1.323 + * could occur when the result has been partially set.
1.324 + */
1.325 +
1.326 + if (linkPtr->flags & LINK_READ_ONLY) {
1.327 + tmpPtr = ObjValue(linkPtr);
1.328 + Tcl_IncrRefCount(tmpPtr);
1.329 + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
1.330 + TCL_GLOBAL_ONLY);
1.331 + Tcl_DecrRefCount(tmpPtr);
1.332 + return "linked variable is read-only";
1.333 + }
1.334 + valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
1.335 + if (valueObj == NULL) {
1.336 + /*
1.337 + * This shouldn't ever happen.
1.338 + */
1.339 + return "internal error: linked variable couldn't be read";
1.340 + }
1.341 +
1.342 + objPtr = Tcl_GetObjResult(interp);
1.343 + Tcl_IncrRefCount(objPtr);
1.344 + Tcl_ResetResult(interp);
1.345 + result = NULL;
1.346 +
1.347 + switch (linkPtr->type) {
1.348 + case TCL_LINK_INT:
1.349 + if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i)
1.350 + != TCL_OK) {
1.351 + Tcl_SetObjResult(interp, objPtr);
1.352 + tmpPtr = ObjValue(linkPtr);
1.353 + Tcl_IncrRefCount(tmpPtr);
1.354 + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
1.355 + TCL_GLOBAL_ONLY);
1.356 + Tcl_DecrRefCount(tmpPtr);
1.357 + result = "variable must have integer value";
1.358 + goto end;
1.359 + }
1.360 + *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
1.361 + break;
1.362 +
1.363 + case TCL_LINK_WIDE_INT:
1.364 + if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w)
1.365 + != TCL_OK) {
1.366 + Tcl_SetObjResult(interp, objPtr);
1.367 + tmpPtr = ObjValue(linkPtr);
1.368 + Tcl_IncrRefCount(tmpPtr);
1.369 + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
1.370 + TCL_GLOBAL_ONLY);
1.371 + Tcl_DecrRefCount(tmpPtr);
1.372 + result = "variable must have integer value";
1.373 + goto end;
1.374 + }
1.375 + *(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w;
1.376 + break;
1.377 +
1.378 + case TCL_LINK_DOUBLE:
1.379 + if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d)
1.380 + != TCL_OK) {
1.381 + Tcl_SetObjResult(interp, objPtr);
1.382 + tmpPtr = ObjValue(linkPtr);
1.383 + Tcl_IncrRefCount(tmpPtr);
1.384 + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
1.385 + TCL_GLOBAL_ONLY);
1.386 + Tcl_DecrRefCount(tmpPtr);
1.387 + result = "variable must have real value";
1.388 + goto end;
1.389 + }
1.390 + *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
1.391 + break;
1.392 +
1.393 + case TCL_LINK_BOOLEAN:
1.394 + if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i)
1.395 + != TCL_OK) {
1.396 + Tcl_SetObjResult(interp, objPtr);
1.397 + tmpPtr = ObjValue(linkPtr);
1.398 + Tcl_IncrRefCount(tmpPtr);
1.399 + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
1.400 + TCL_GLOBAL_ONLY);
1.401 + Tcl_DecrRefCount(tmpPtr);
1.402 + result = "variable must have boolean value";
1.403 + goto end;
1.404 + }
1.405 + *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
1.406 + break;
1.407 +
1.408 + case TCL_LINK_STRING:
1.409 + value = Tcl_GetStringFromObj(valueObj, &valueLength);
1.410 + valueLength++;
1.411 + pp = (char **)(linkPtr->addr);
1.412 + if (*pp != NULL) {
1.413 + ckfree(*pp);
1.414 + }
1.415 + *pp = (char *) ckalloc((unsigned) valueLength);
1.416 + memcpy(*pp, value, (unsigned) valueLength);
1.417 + break;
1.418 +
1.419 + default:
1.420 + return "internal error: bad linked variable type";
1.421 + }
1.422 + end:
1.423 + Tcl_DecrRefCount(objPtr);
1.424 + return result;
1.425 +}
1.426 +
1.427 +/*
1.428 + *----------------------------------------------------------------------
1.429 + *
1.430 + * ObjValue --
1.431 + *
1.432 + * Converts the value of a C variable to a Tcl_Obj* for use in a
1.433 + * Tcl variable to which it is linked.
1.434 + *
1.435 + * Results:
1.436 + * The return value is a pointer to a Tcl_Obj that represents
1.437 + * the value of the C variable given by linkPtr.
1.438 + *
1.439 + * Side effects:
1.440 + * None.
1.441 + *
1.442 + *----------------------------------------------------------------------
1.443 + */
1.444 +
1.445 +static Tcl_Obj *
1.446 +ObjValue(linkPtr)
1.447 + Link *linkPtr; /* Structure describing linked variable. */
1.448 +{
1.449 + char *p;
1.450 +
1.451 + switch (linkPtr->type) {
1.452 + case TCL_LINK_INT:
1.453 + linkPtr->lastValue.i = *(int *)(linkPtr->addr);
1.454 + return Tcl_NewIntObj(linkPtr->lastValue.i);
1.455 + case TCL_LINK_WIDE_INT:
1.456 + linkPtr->lastValue.w = *(Tcl_WideInt *)(linkPtr->addr);
1.457 + return Tcl_NewWideIntObj(linkPtr->lastValue.w);
1.458 + case TCL_LINK_DOUBLE:
1.459 + linkPtr->lastValue.d = *(double *)(linkPtr->addr);
1.460 + return Tcl_NewDoubleObj(linkPtr->lastValue.d);
1.461 + case TCL_LINK_BOOLEAN:
1.462 + linkPtr->lastValue.i = *(int *)(linkPtr->addr);
1.463 + return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
1.464 + case TCL_LINK_STRING:
1.465 + p = *(char **)(linkPtr->addr);
1.466 + if (p == NULL) {
1.467 + return Tcl_NewStringObj("NULL", 4);
1.468 + }
1.469 + return Tcl_NewStringObj(p, -1);
1.470 +
1.471 + /*
1.472 + * This code only gets executed if the link type is unknown
1.473 + * (shouldn't ever happen).
1.474 + */
1.475 + default:
1.476 + return Tcl_NewStringObj("??", 2);
1.477 + }
1.478 +}