/* * t4storagerep.cpp -- * * This file contains the implementation of the class T4Storage * which is defined in .../include/t4graphrep.h. * * Authors: Jacob Levy and Jean-Claude Wippler. * jyl@best.com jcw@equi4.com * * Copyright (c) 2000-2003, JYL Software Inc. * * Permission is hereby granted, free of charge, to any person obtaining * a copy of this software and associated documentation files (the * "Software"), to deal in the Software without restriction, including * without limitation the rights to use, copy, modify, merge, publish, * distribute, sublicense, and/or sell copies of the Software, and to * permit persons to whom the Software is furnished to do so, subject to * the following conditions: * * The above copyright notice and this permission notice shall be * included in all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE * LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION * OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE, EVEN IF * JYL SOFTWARE INC. IS MADE AWARE OF THE POSSIBILITY OF SUCH DAMAGE. */ #include "t4graphrep.h" /* * These functions are declared for Tcl script callbacks. */ static void NodeAddCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4CallbackRecord *c = (T4CallbackRecord *) clientData; e4_Node n = (e4_Node) r; c->storage->AddNodeCallback(c->interp, n); } static void VertexAddCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4CallbackRecord *c = (T4CallbackRecord *) clientData; e4_Vertex v = (e4_Vertex) r; c->storage->AddVertexCallback(c->interp, v); } static void NodeDetCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4CallbackRecord *c = (T4CallbackRecord *) clientData; e4_Node n = (e4_Node) r; c->storage->DetNodeCallback(c->interp, n); } static void VertexDetCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4CallbackRecord *c = (T4CallbackRecord *) clientData; e4_Vertex v = (e4_Vertex) r; c->storage->DetVertexCallback(c->interp, v); } static void NodeAttCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4CallbackRecord *c = (T4CallbackRecord *) clientData; e4_Node n = (e4_Node) r; c->storage->AttNodeCallback(c->interp, n); } static void VertexAttCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4CallbackRecord *c = (T4CallbackRecord *) clientData; e4_Vertex v = (e4_Vertex) r; c->storage->AttVertexCallback(c->interp, v); } static void VertexModCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4StoragePerInterp *spp = (T4StoragePerInterp *) clientData; e4_Vertex v = (e4_Vertex) r; e4_ModVertexEventReason cbr = (e4_ModVertexEventReason) (int) csdata; spp->storage->ModVertexCallback(spp, v, cbr); } static void NodeModCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4StoragePerInterp *spp = (T4StoragePerInterp *) clientData; e4_Node n = (e4_Node) r; e4_ModNodeEventReason cbr = (e4_ModNodeEventReason) (int) csdata; spp->storage->ModNodeCallback(spp, n, cbr); } static void StorageChangeCallbackFn(void *clientData, const e4_RefCount &r, void *csdata) { T4CallbackRecord *c = (T4CallbackRecord *) clientData; c->storage->ChangeStorageCallback(c->interp); } /* * Constructor: */ T4Storage::T4Storage(e4_Storage ss, char *fn, char *dn) { /* * So far this storage is not in any interpreter. */ spip = NULL; /* * Copy the given e4_Storage object into our cache. */ s = ss; /* * Save the driver and file names. */ fname = strdup(fn); drivername = strdup(dn); } /* * Destructor: */ T4Storage::~T4Storage() { while (spip != NULL) { this->InternalClose(spip->interp, false); } /* * Unregister this storage in the global storage registry. */ if (s.IsValid()) { T4Graph_UnregisterStorage(s.GetTemporaryUID()); } /* * Free the allocated storage: */ s = invalidStorage; /* * Discard the strings for the driver and file names. */ free(fname); free(drivername); } /* * RemoveAllCallbacks -- * * Clean up the callback facility. * * Results: * None. * * Side effects: * All callbacks registered on this storage are cancelled. */ void T4Storage::RemoveAllCallbacks(T4StoragePerInterp *spp) { Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *o; /* * Remove the callbacks that are installed for T4Graph maintainence: */ s.DeleteCallback(E4_ECMODNODE, NodeModCallbackFn, (void *) spp); s.DeleteCallback(E4_ECMODVERTEX, VertexModCallbackFn, (void *) spp); /* * Clean up the callback facility. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { /* * Discard the script. */ o = (Tcl_Obj *) Tcl_GetHashValue(ePtr); Tcl_DecrRefCount(o); /* * Discard the callback record. */ r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); delete r; } Tcl_DeleteHashTable(spp->callbacks); Tcl_Free((char *) spp->callbacks); spp->callbacks = NULL; /* * Discard callback records for each callback kind. */ if (spp->cbaddnode > 0) { s.DeleteCallback(E4_ECADDNODE, NodeAddCallbackFn, (void *) spp->cbAddNodeRecord); delete spp->cbAddNodeRecord; spp->cbAddNodeRecord = NULL; spp->cbaddnode = 0; } if (spp->cbaddvertex > 0) { s.DeleteCallback(E4_ECADDVERTEX, VertexAddCallbackFn, (void *) spp->cbAddVertexRecord); delete spp->cbAddVertexRecord; spp->cbAddVertexRecord = NULL; spp->cbaddvertex = 0; } if (spp->cbdetnode > 0) { s.DeleteCallback(E4_ECDETNODE, NodeDetCallbackFn, (void *) spp->cbDetNodeRecord); delete spp->cbDetNodeRecord; spp->cbDetNodeRecord = NULL; spp->cbdetnode = 0; } if (spp->cbdetvertex > 0) { s.DeleteCallback(E4_ECDETVERTEX, VertexDetCallbackFn, (void *) spp->cbDetVertexRecord); delete spp->cbDetVertexRecord; spp->cbDetVertexRecord = NULL; spp->cbdetvertex = 0; } if (spp->cbattnode > 0) { s.DeleteCallback(E4_ECATTNODE, NodeAttCallbackFn, (void *) spp->cbAttNodeRecord); delete spp->cbAttNodeRecord; spp->cbAttNodeRecord = NULL; spp->cbattnode = 0; } if (spp->cbattvertex > 0) { s.DeleteCallback(E4_ECATTVERTEX, VertexAttCallbackFn, (void *) spp->cbAttVertexRecord); delete spp->cbAttVertexRecord; spp->cbAttVertexRecord = NULL; spp->cbattvertex = 0; } if (spp->cbchgstorage > 0) { s.DeleteCallback(E4_ECCHANGESTG, StorageChangeCallbackFn, (void *) spp->cbChgStorageRecord); delete spp->cbChgStorageRecord; spp->cbChgStorageRecord = NULL; spp->cbchgstorage = 0; } } /* * GetNodeById -- * * Given a hash id, retrieve the associated T4Node object. * * Results: * The T4Node object if found, NULL otherwise. * * Side effects: * None. */ T4Node * T4Storage::GetNodeById(Tcl_Interp *interp, e4_NodeUniqueID nuid) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *hPtr; int id = nuid.GetUniqueID(); if (spp == NULL) { return NULL; } hPtr = Tcl_FindHashEntry(spp->exportedNodes, (char *) id); if (hPtr == NULL) { return NULL; } return (T4Node *) Tcl_GetHashValue(hPtr); } /* * GetVertexById -- * * Given a hash id, retrieve the associated T4Vertex object. * * Results: * The T4Vertex object if found, NULL otherwise. * * Side effects: * None. */ T4Vertex * T4Storage::GetVertexById(Tcl_Interp *interp, e4_VertexUniqueID vuid) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *hPtr; int id = vuid.GetUniqueID(); if (spp == NULL) { return NULL; } hPtr = Tcl_FindHashEntry(spp->exportedVertices, (char *) id); if (hPtr == NULL) { return NULL; } return (T4Vertex *) Tcl_GetHashValue(hPtr); } /* * ClearVertexStoredState -- * * Clear stored state associated with a vertex. This works whether or * not the vertex is exported to Tcl. * * Results: * None. * * Side effects: * May release a Tcl_Obj object, and may undefine a procedure. */ void T4Storage::ClearVertexStoredState(Tcl_Interp *interp, e4_Vertex v) const { T4StoragePerInterp *spp = ((T4Storage *) this)->GetStoragePerInterp(interp); e4_VertexUniqueID vuid; int id; Tcl_HashEntry *ep; T4CmdInfo *cmdInfo; Tcl_Obj *obj; if (spp == NULL) { return; } (void) v.GetUniqueID(vuid); id = vuid.GetUniqueID(); ep = Tcl_FindHashEntry(spp->storedProcs, (char *) id); if (ep != NULL) { cmdInfo = (T4CmdInfo *) Tcl_GetHashValue(ep); Tcl_DeleteCommand(interp, cmdInfo->cmdName); Tcl_Free(cmdInfo->cmdName); Tcl_Free((char *) cmdInfo); Tcl_DeleteHashEntry(ep); } ep = Tcl_FindHashEntry(spp->storedValues, (char *) id); if (ep != NULL) { obj = (Tcl_Obj *) Tcl_GetHashValue(ep); Tcl_DecrRefCount(obj); Tcl_DeleteHashEntry(ep); } } /* * SetVertexStoredObject -- * * Sets the stored Tcl_Object associated with a vertex. This works whether * or not the vertex is exported to Tcl. * * Results: * None. * * Side effects: * May release a Tcl_Obj. After this operation, retrieving the stored * object for this vertex will return the object passed in this call. */ void T4Storage::SetVertexStoredObject(Tcl_Interp *interp, e4_Vertex v, Tcl_Obj *obj) const { T4StoragePerInterp *spp = ((T4Storage *) this)->GetStoragePerInterp(interp); e4_VertexUniqueID vuid; int id, isnew; Tcl_HashEntry *ep; Tcl_Obj *oldobj; if (spp == NULL) { return; } (void) v.GetUniqueID(vuid); id = vuid.GetUniqueID(); ep = Tcl_CreateHashEntry(spp->storedValues, (char *) id, &isnew); if (!isnew) { oldobj = (Tcl_Obj *) Tcl_GetHashValue(ep); Tcl_DecrRefCount(oldobj); } Tcl_IncrRefCount(obj); Tcl_SetHashValue(ep, obj); } /* * SetVertexStoredCmdInfo -- * * Sets the CmdInfo structure associated with a vertex. This works * whether or not this vertex has been exported to Tcl. * * Results: * None. * * Side effects: * Sets the command info, may undefine a previously defined procedure. */ void T4Storage::SetVertexStoredCmdInfo(Tcl_Interp *interp, e4_Vertex v, T4CmdInfo *cmdInfo) const { T4StoragePerInterp *spp = ((T4Storage *) this)->GetStoragePerInterp(interp); e4_VertexUniqueID vuid; int id, isnew; Tcl_HashEntry *ep; T4CmdInfo *oldcmd; if (spp == NULL) { return; } (void) v.GetUniqueID(vuid); id = vuid.GetUniqueID(); ep = Tcl_CreateHashEntry(spp->storedProcs, (char *) id, &isnew); if (!isnew) { oldcmd = (T4CmdInfo *) Tcl_GetHashValue(ep); Tcl_DeleteCommand(interp, oldcmd->cmdName); Tcl_Free(oldcmd->cmdName); Tcl_Free((char *) oldcmd); } Tcl_SetHashValue(ep, cmdInfo); } /* * GetVertexStoredObject -- * * Returns a stored Tcl object that represents the value of a vertex. * * Results: * A Tcl_Obj * if there's a stored Tcl_Obj for the requested vertex, * or NULL. * * Side effects: * None. */ Tcl_Obj * T4Storage::GetVertexStoredObject(Tcl_Interp *interp, e4_Vertex v) const { T4StoragePerInterp *spp = ((T4Storage *) this)->GetStoragePerInterp(interp); e4_VertexUniqueID vuid; int id; Tcl_HashEntry *ep; if (spp == NULL) { return NULL; } (void) v.GetUniqueID(vuid); id = vuid.GetUniqueID(); ep = Tcl_FindHashEntry(spp->storedValues, (char *) id); if (ep == NULL) { return NULL; } return (Tcl_Obj *) Tcl_GetHashValue(ep); } /* * GetVertexStoredCmdInfo -- * * Retrieve a T4CmdInfo * if one is stored for the requested vertex. * * Results: * A T4CmdInfo * if one is available, or NULL. * * Side effects: * None. */ T4CmdInfo * T4Storage::GetVertexStoredCmdInfo(Tcl_Interp *interp, e4_Vertex v) const { T4StoragePerInterp *spp = ((T4Storage *) this)->GetStoragePerInterp(interp); e4_VertexUniqueID vuid; int id; Tcl_HashEntry *ep; if (spp == NULL) { return NULL; } (void) v.GetUniqueID(vuid); id = vuid.GetUniqueID(); ep = Tcl_FindHashEntry(spp->storedProcs, (char *) id); if (ep == NULL) { return NULL; } return (T4CmdInfo *) Tcl_GetHashValue(ep); } /* * StoreNode -- * * Make a new entry in the exported nodes table for the given * T4Node object under the supplied id. * * Results: * None. * * Side effects: * Subsequently the node can be retrieved given the supplied id. */ void T4Storage::StoreNode(Tcl_Interp *interp, T4Node *n, int id) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *hPtr; int isnew; if (spp == NULL) { return; } hPtr = Tcl_CreateHashEntry(spp->exportedNodes, (char *) id, &isnew); if (!isnew) { /* * Should panic! */ fprintf(stderr, "TGRAPH: duplicate node storage for %d: 0x%x and 0x%x\n", id, n, (int) Tcl_GetHashValue(hPtr)); return; } Tcl_SetHashValue(hPtr, n); } /* * StoreVertex -- * * Make a new entry in the exported vertices table for the given * T4Vertex object under the supplied id. * * Results: * None. * * Side effects: * Subsequently the vertex can be retrieved given the supplied id. */ void T4Storage::StoreVertex(Tcl_Interp *interp, T4Vertex *f, int id) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *hPtr; int isnew; if (spp == NULL) { return; } hPtr = Tcl_CreateHashEntry(spp->exportedVertices, (char *) id, &isnew); if (!isnew) { /* * Should panic! */ fprintf(stderr, "TGRAPH: duplicate vertex storage for %d: 0x%x and 0x%x\n", id, f, (int) Tcl_GetHashValue(hPtr)); return; } Tcl_SetHashValue(hPtr, f); } /* * RemoveNode -- * * Given an id, removes the entry for the associated node * from the hash table of exported nodes in this storage. * * Results: * None. * * Side effects: * Subsequently the node can no longer be retrieved given the id. */ void T4Storage::RemoveNode(Tcl_Interp *interp, e4_NodeUniqueID nuid) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *hPtr; int id = nuid.GetUniqueID(); if (spp == NULL) { return; } if (spp->exportedNodes == NULL) { return; } hPtr = Tcl_FindHashEntry(spp->exportedNodes, (char *) id); if (hPtr == NULL) { return; } Tcl_DeleteHashEntry(hPtr); } /* * RemoveVertex -- * * Given an id, removes the entry for the associated vertex * from the hash table of exported vertices in this storage. * * Results: * None. * * Side effects: * Subsequently the vertex can no longer be retrieved given the id. */ void T4Storage::RemoveVertex(Tcl_Interp *interp, e4_VertexUniqueID vuid) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *hPtr; int id = vuid.GetUniqueID(); if (spp == NULL) { return; } if (spp->exportedVertices == NULL) { return; } hPtr = Tcl_FindHashEntry(spp->exportedVertices, (char *) id); if (hPtr == NULL) { return; } Tcl_DeleteHashEntry(hPtr); } /* * ExternalizeStorage -- * * This procedure gives the caller access to the underlying * e4_Storage object. * * Results: * None. * * Side effects: * The caller can now manipulate the underlying e4_Storage * object directly. */ void T4Storage::ExternalizeStorage(e4_Storage &ss) { ss = s; } /* **************************************************************************** * * The following methods implement Tcl sub-commands on a T4Storage * object. * **************************************************************************** */ /* * Close -- * * Remove the T4Storage object from this interpreter without * Deleteing it. If this is the last reference to the underlying * e4Graph storage object then it will be closed. * * Results: * A standard Tcl result. * * Side effects: * The storage is no longer accessible in this interpreter, and * all T4Graph objects that belong in this storage that have been * exported to Tcl become invalid. */ int T4Storage::Close(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage close"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } return InternalClose(interp, true); } /* * Helper function for closing the storage and cleaning up its state. */ int T4Storage::InternalClose(Tcl_Interp *interp, bool selfdestruct) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashSearch search; Tcl_HashEntry *ep; Tcl_Obj *obj; char buf[128]; int tid = s.GetTemporaryUID(); /* * If the storage is not available in this interpreter, error out. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage \"", GetName(), "\" is not available in this interpreter", NULL); return TCL_ERROR; } /* * Splice it out of the list of per-interpreter records. */ if (spip == spp) { spip = spp->next; } if (spp->prev != NULL) { spp->prev->next = spp->next; } if (spp->next != NULL) { spp->next->prev = spp->prev; } /* * Clean up all the storage associated with this per-interpreter record. */ Tcl_DeleteHashTable(spp->exportedNodes); Tcl_Free((char *) spp->exportedNodes); Tcl_DeleteHashTable(spp->exportedVertices); Tcl_Free((char *) spp->exportedVertices); for (ep = Tcl_FirstHashEntry(spp->storedValues, &search); ep != NULL; ep = Tcl_NextHashEntry(&search)) { obj = (Tcl_Obj *) Tcl_GetHashValue(ep); Tcl_DecrRefCount(obj); } Tcl_DeleteHashTable(spp->storedProcs); Tcl_Free((char *) spp->storedProcs); Tcl_DeleteHashTable(spp->storedValues); Tcl_Free((char *) spp->storedValues); /* * Delete the Tcl command for this storage, and delete this T4Storage * object from the hash table for storages that are open in this interp. * Also remove all exported objects from this storage in this interp. */ T4Graph_DeleteStorageCommand(interp, this); /* * Remove the namespace for stored procedures from the interpreter. This * will undefine all of them in one step. */ sprintf(buf, "namespace delete ::tgraph::%s", GetName()); (void) Tcl_Eval(interp, buf); Tcl_ResetResult(interp); /* * Clean up the callback facility. */ RemoveAllCallbacks(spp); /* * Destroy the per-interpreter record itself. */ delete spp; /* * If other interpreters still hold a reference to this storage * then don't destroy it. */ if ((spip != NULL) || (!selfdestruct)) { return TCL_OK; } /* * No more references to this storage remain, so we delete its instance. * The destructor closes the storage by explicitly assigning * invalidStorage to the instance variable. */ delete this; return TCL_OK; } /* * Commit -- * * Commit any changes to this object to persistent storage. * * Results: * A standard Tcl result. * * Side effects: * After this operation, the state of exported T4Graph objects * exactly reflects the state in the persistent storage. */ int T4Storage::Commit(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage commit"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Attempt to commit. */ if (!s.Commit()) { Tcl_AppendResult(interp, "commit on storage ", GetName(), " failed", NULL); return TCL_ERROR; } return TCL_OK; } /* * CopyTo -- * * Copies the contents of this e4Graph storage object to the given * e4Graph storage object. * * Results: * A standard Tcl result. * * Side effects: * After this operation the other storage contains the same structure * as this storage. All objects belonging to the other storage become * invalid. */ int T4Storage::CopyTo(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int forceCommit = 0; Tcl_HashTable *storages; Tcl_HashEntry *ePtr; T4Storage *otherStorage; e4_Storage os; /* * Expecting one or two arguments. */ if ((objc != 1) && (objc != 2)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage copyto otherstorage ?commit?"); return TCL_ERROR; } /* * If there are two arguments, attempt to obtain the boolean that * says whether we want to commit the other storage after the copy. */ if (objc == 2) { if (Tcl_GetBooleanFromObj(interp, objv[1], &forceCommit) != TCL_OK) { return TCL_ERROR; } } /* * Check that the underlying storage is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Attempt to get the storage from the given argument. */ storages = (Tcl_HashTable *) Tcl_GetAssocData(interp, T4_ASSOCKEY, NULL); if (storages == NULL) { Tcl_AppendResult(interp, "internal error: invalid storage hash", " table", NULL); return TCL_ERROR; } ePtr = Tcl_FindHashEntry(storages, Tcl_GetString(objv[0])); if (ePtr == NULL) { Tcl_AppendResult(interp, "unknown storage ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } otherStorage = (T4Storage *) Tcl_GetHashValue(ePtr); if (otherStorage == NULL) { Tcl_AppendResult(interp, "unknown storage ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } /* * Obtain the e4Graph object for the other storage. */ otherStorage->ExternalizeStorage(os); /* * Check the other storage is valid. */ if (!os.IsValid()) { Tcl_AppendResult(interp, "invalid storage ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } /* * Attempt to copy. */ if (!s.CopyTo(os, (forceCommit == 0) ? false : true)) { Tcl_AppendResult(interp, "copy from ", GetName(), " to ", Tcl_GetString(objv[0]), " failed", NULL); return TCL_ERROR; } /* * If we get here, success */ Tcl_ResetResult(interp); return TCL_OK; } /* * Delete -- * * Deletes the underlying e4Graph storage object and the T4Graph * storage object. * * Results: * A standard Tcl result. * * Side effects: * The persistent storage for the T4Graph object may be Deleteed. * After this operation, the T4Graph object can no longer be accessed * in this interpreter and any T4Graph objects exported to Tcl that * belong in this storage become invalid. */ int T4Storage::Delete(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Storage hold; /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage Delete"); return TCL_ERROR; } /* * Check that the underlying storage is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Hold onto the storage while we're closing this instance's reference. */ hold = s; /* * Now clean up the in-core state. */ if (InternalClose(interp, true) != TCL_OK) { return TCL_ERROR; } /* * And finally delete the storage through the handle we held onto. */ hold.Delete(); return TCL_OK; } /* * DoGC -- * * Cause a GC to occur in the e4Graph storage attached to this * T4Graph storage object. * * Results: * A standard Tcl result. Upon success the interpreter result is empty. * * Side effects: * Causes a garbage collection. Detach callbacks may issue. */ int T4Storage::DoGC(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, "$storage dogc"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } s.DoGC(); Tcl_ResetResult(interp); return TCL_OK; } /* * NeedsGC -- * * Returns a boolean value saying whether the e4Graph storage * attached to this TGraph storage object needs GC. * * Results: * A standard Tcl result. Upon success the interpreter result * contains a boolean saying whether the underlying storage * needs a GC. * * Side effects: * None. */ int T4Storage::NeedsGC(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, "$storage needsgc"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } Tcl_SetBooleanObj(Tcl_GetObjResult(interp), s.NeedsGC()); return TCL_OK; } /* * Node -- * * Creates and returns a new detached node within the underlying * storage. * * Results: * A standard Tcl result. Upon success, the interpreter result contains * the Tcl name of the new node. * * Side effects: * May create a new node in the storage. */ int T4Storage::Node(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Node n; T4Node *np; e4_NodeUniqueID nuid; Tcl_Obj *res; /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, "$storage node"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Attempt to create a new detached node: */ if ((!s.CreateDetachedNode(n)) || (!n.IsValid())) { Tcl_AppendResult(interp, "could not create new detached node in storage ", GetName(), NULL); return TCL_ERROR; } /* * Export the new detached node to Tcl. It's possible that it has * already been exported by a callback. If so, just use the same * T4Node. */ (void) n.GetUniqueID(nuid); np = GetNodeById(interp, nuid); if (np == NULL) { np = new T4Node(n, this); StoreNode(interp, np, nuid); } res = np->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, np, interp); np->SetTclObject(res); } Tcl_SetObjResult(interp, res); return TCL_OK; } /* * Vertex -- * * Create and return a new detached vertex in this storage. * * Results: * A standard Tcl result. Upon success, the interpreter result contains * the Tcl name of the new vertex. * * Side effects: * May create a new vertex in the storage. */ int T4Storage::Vertex(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; T4Vertex *vp; e4_VertexUniqueID vuid; Tcl_Obj *res; /* * Expecting two or three arguments: name, value and optional * type selector. */ if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage vertex name val ?typesel?"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Attempt to create a new detached vertex. Create it with the * default value of (integer) 0. */ if ((!s.CreateDetachedVertex((const char *) Tcl_GetString(objv[0]), 0, v)) || (!v.IsValid())) { Tcl_AppendResult(interp, "could not create new detached vertex in storage ", GetName(), NULL); return TCL_ERROR; } /* * Export the new detached vertex to Tcl. It may already have been exported * by a vertex add callback. In that case use the one that's already * registeterd. */ (void) v.GetUniqueID(vuid); vp = GetVertexById(interp, vuid); if (vp == NULL) { vp = new T4Vertex(v, this); StoreVertex(interp, vp, vuid); } res = vp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(vertexExt, vp, interp); vp->SetTclObject(res); } /* * Set the vertex to its real value. */ if (vp->Set(interp, objc-1, objv+1) == TCL_ERROR) { return TCL_ERROR; } /* * Return the name of the new detached vertex. */ Tcl_SetObjResult(interp, res); return TCL_OK; } /* * Root -- * * When called with zero arguments, returns the T4Graph object that * represents the root node. * * When called with one argument, the name of a valid node, sets the * root node of that storage to the given node. * * Results: * A valid Tcl result. When called with zero arguments, upon success * the interpreter result contains the name of the root node (as * exported to Tcl). * * Side effects: * May change which node is the root node of this storage. */ int T4Storage::Root(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { char *nn; e4_Node n; T4Node *np; e4_NodeUniqueID nuid; Tcl_Obj *res; /* * Expecting zero or one arguments. */ if ((objc != 0) && (objc != 1)) { Tcl_WrongNumArgs(interp, 0, NULL, "$storage root ?newroot?"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * If there is one argument, check that it is the name of an exported * node. */ if (objc == 1) { nn = Tcl_GetString(objv[0]); /* * Obtain the node denoted by the supplied Tcl_Obj. */ np = (T4Node *) GO_GetInternalRep(objv[0], nodeExt); if (np == NULL) { Tcl_AppendResult(interp, "invalid node ", nn, NULL); return TCL_ERROR; } np->ExternalizeNode(n); if (!n.IsValid()) { Tcl_AppendResult(interp, "invalid node ", nn, NULL); return TCL_ERROR; } /* * Attempt to set the root node of this storage to the given node. */ if (!s.SetRootNode(n)) { Tcl_AppendResult(interp, "could not set root node of storage ", GetName(), " to node ", np->GetName(), NULL); return TCL_ERROR; } /* * Clear the interpreter result, don't leave turds! */ Tcl_ResetResult(interp); return TCL_OK; } /* * Zero arguments: retrieve the root node and export it to Tcl. */ if ((!s.GetRootNode(n)) || (!n.IsValid())) { Tcl_AppendResult(interp, "could not obtain root of storage ", GetName(), NULL); return TCL_ERROR; } /* * See if we have exported this node to Tcl before. If not, create * a new T4Node and make it ready to be exported. */ (void) n.GetUniqueID(nuid); np = GetNodeById(interp, nuid); if (np == NULL) { np = new T4Node(n, this); StoreNode(interp, np, nuid); } res = np->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, np, interp); np->SetTclObject(res); } Tcl_SetObjResult(interp, res); return TCL_OK; } /* * IsValid -- * * Returns a boolean value indicating whether the T4Graph storage * object is valid. * * Results: * A standard Tcl result. Upon success the interpreter result * contains a boolean value indicating whether the storage is * valid. * * Side effects: * None. */ int T4Storage::IsValid(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage isvalid"); return TCL_ERROR; } /* * Is this storage valid? */ if (s.IsValid()) { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } /* * IsStable -- * * Returns a boolean value indicating whether the T4Graph storage * object is stable (it needs to be committed). * * Results: * A standard Tcl result. Upon success the interpreter result * contains a boolean value indicating whether the storage is * stable. * * Side effects: * None. */ int T4Storage::IsStable(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage isstable"); return TCL_ERROR; } /* * Is this storage stable? */ if (s.IsStable()) { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } /* * MarkUnstable -- * * Mark the storage as unstable (it needs to be committed). * * Results: * A standard Tcl result. * * Side effects: * The storage is marked as unstable (it needs to be committed). */ int T4Storage::MarkUnstable(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage markunstable"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Mark the storage as unstable. */ s.MarkUnstable(); return TCL_OK; } /* * Name -- * * Sets the interpreter result to the name of this storage. * * Results: * A standard Tcl result. Upon success the interpreter result * contains a string, the name of this storage. * * Side effects: * None. */ int T4Storage::Name(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage name"); return TCL_ERROR; } /* * Check that the storage object is valid. */ if (!s.IsValid()) { Tcl_AppendResult(interp, "storage ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Return the string name of this storage. If the interpreter is * safe, do not tell him the real name of the storage. Instead tell * him only the name by which it is known in Tcl. */ if (Tcl_IsSafe(interp)) { Tcl_SetStringObj(Tcl_GetObjResult(interp), GetName(), -1); } else { Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) s.GetName(), -1); } return TCL_OK; } /* * Foreach -- * * Iterate over selected elements in this storage, executing an * arbitrary piece of Tcl code for each selected element. * * Results: * A standard Tcl result. Upon successful completion, the interpreter * result is left empty. * * Side effects: * Whatever the evaluated Tcl code does. May export new elements of * this storage to Tcl. */ static CONST84 char *selectors[] = { (char *) "node", (char *) "vertex", (char *) NULL }; typedef enum SSelectors { SNode = 0, SVertex } SSelectors; static CONST84 char *choices[] = { (char *) "detached", (char *) "attached", (char *) "both", (char *) NULL }; int T4Storage::Foreach(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { SSelectors index; /* * Expecting at least three arguments. */ if (objc < 3) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage foreach sel var ?options? cmd"); return TCL_ERROR; } /* * Figure out what selector was requested. */ if (Tcl_GetIndexFromObj(interp, objv[0], (CONST84 char **) selectors, (char *) "selector", 0, (int *) &index) != TCL_OK) { return TCL_ERROR; } objc--; objv++; switch (index) { case SNode: return VisitNodes(interp, objc, objv); case SVertex: return VisitVertices(interp, objc, objv); } /* * Not reached, but some compilers insist on this.. */ return TCL_ERROR; } /* * These filters help select nodes and vertices to visit. */ static CONST84 char *filters[] = { (char *) "-type", (char *) "-name", (char *) "-class", (char *) NULL }; typedef enum SFilters { SType = 0, SName, SClass, } SFilters; /* * VisitNodes -- * * Helper function to visit selected nodes in a storage. * * Results: * A standard Tcl result. Upon successful completion, the interpreter * result is left empty. * * Side effects: * Whatever the evaluated Tcl code does. May export new elements of * this storage to Tcl. */ int T4Storage::VisitNodes(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Node n = invalidNode; e4_NodeUniqueID nuid; T4Node *np; int ret = TCL_OK, retone; bool done = false; Tcl_Obj *vp1, *vp2; Tcl_Obj *res; Tcl_Obj *cmd; e4_DetachChoice dc; /* * Expecting two or four arguments, the name of a variable to * set to each node as it is visited, and the command to execute. * If four arguments are present, the two additional ones are * expected to be "-class" and a string from the "choices" array * above. */ if ((objc != 2) && (objc != 4)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage foreach node var ?-class c? cmd"); return TCL_ERROR; } /* * Get the variable name. */ vp1 = objv[0]; vp2 = NULL; /* * Get the command to execute. */ if (objc == 2) { cmd = objv[1]; } else { cmd = objv[3]; } /* * Select which group of nodes to visit. */ if (objc == 2) { dc = E4_DCATTACHED; } else { char *s = Tcl_GetString(objv[1]); if (strncmp(s, "-class", strlen(s)) != 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "Incorrect flag \"", s, "\", expected ", "-class", NULL); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], (CONST84 char **) choices, (char *) "class", 0, (int *) &dc) != TCL_OK) { return TCL_ERROR; } } /* * Create the iterator. */ e4_NodeVisitor nv(s, dc); /* * Iterate over every node in the storage. */ while ((!done) && (nv.CurrentNodeAndAdvance(n))) { /* * See if we already exported this node to Tcl. */ (void) n.GetUniqueID(nuid); np = GetNodeById(interp, nuid); if (np == NULL) { np = new T4Node(n, this); StoreNode(interp, np, nuid); } res = np->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, np, interp); np->SetTclObject(res); } /* * Set the iteration variable to the Tcl_Obj * for this node. */ (void) Tcl_ObjSetVar2(interp, vp1, vp2, res, 0); /* * And finally execute the command. */ retone = Tcl_EvalObjEx(interp, cmd, 0); switch (retone) { case TCL_OK: case TCL_CONTINUE: Tcl_ResetResult(interp); break; case TCL_BREAK: Tcl_ResetResult(interp); done = true; break; case TCL_ERROR: default: done = true; ret = retone; break; } } (void) Tcl_UnsetVar(interp, Tcl_GetString(vp1), 0); return ret; } /* * VisitVertices -- * * Helper function to visit selected vertices in a storage. * * Results: * A standard Tcl result. Upon successful completion, the interpreter * result is left empty. * * Side effects: * Whatever the evaluated Tcl command does. May export new elements * of the storage to Tcl. */ static CONST84 char *typenames[] = { (char *) "node", (char *) "int", (char *) "float", (char *) "string", (char *) "binary", (char *) NULL }; int T4Storage::VisitVertices(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v = invalidVertex; e4_VertexUniqueID vuid; T4Vertex *vp; char *namefilter = NULL; SFilters filter; e4_VertexType vt = E4_VTUNKNOWN; int ret = TCL_OK, retone; bool done = false; Tcl_Obj *vp1, *vp2; Tcl_Obj *res; e4_DetachChoice dc = E4_DCATTACHED; /* * Expecting two, four, six or eight arguments, the name of a variable * to set to each vertex as it is visited, an optional type filter * (two args), an optional name filter (two args), an optional set of * entities (both, detached or attached) (two args), and the command * to execute. */ if ((objc != 2) && (objc != 4) && (objc != 6) && (objc != 8)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage foreach vertex v ?-class c? ?-type t? ?-name n? cmd"); return TCL_ERROR; } /* * Get the iteration variable: */ vp1 = objv[0]; vp2 = NULL; /* * Parse the optional specifiers: */ for (objc--, objv++; objc > 1; objc -= 2, objv += 2) { if (Tcl_GetIndexFromObj(interp, objv[0], (CONST84 char **) filters, (char *) "filter", 0, (int *) &filter) != TCL_OK) { return TCL_ERROR; } switch (filter) { case SName: namefilter = Tcl_GetString(objv[1]); break; case SType: if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **) typenames, (char *) "typename", 0, (int *) &vt) != TCL_OK) { return TCL_ERROR; } break; case SClass: if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **) choices, (char *) "class", 0, (int *) &dc) != TCL_OK) { return TCL_ERROR; } } } /* * Create the iterator: */ e4_VertexVisitor vv(s, dc, (const char *) namefilter, vt); /* * Iterate over the selected vertices. */ while ((!done) && (vv.CurrentVertexAndAdvance(v))) { /* * See if we already exported this vertex to Tcl. */ (void) v.GetUniqueID(vuid); vp = GetVertexById(interp, vuid); if (vp == NULL) { vp = new T4Vertex(v, this); StoreVertex(interp, vp, vuid); } res = vp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(vertexExt, vp, interp); vp->SetTclObject(res); } /* * Set the iteration variable. */ (void) Tcl_ObjSetVar2(interp, vp1, vp2, res, 0); /* * And finally execute the command. */ retone = Tcl_EvalObjEx(interp, objv[0], 0); switch (retone) { case TCL_OK: case TCL_CONTINUE: Tcl_ResetResult(interp); break; case TCL_BREAK: Tcl_ResetResult(interp); done = true; break; case TCL_ERROR: default: done = true; ret = retone; break; } } /* * Unset the iteration variable. */ (void) Tcl_UnsetVar(interp, Tcl_GetString(vp1), 0); return ret; } /* * Statistic -- * * Retrieve a statistic collected while running a TGraph application. * * Results: * A standard Tcl result. Upon success, the interpreter result contains * the value of the statistic retrieved. * * Side effects: * None. */ static CONST84 char *statspaceselectors[] = { (char *) "node", (char *) "vertex", (char *) "name", (char *) "string", (char *) "int", (char *) "float", (char *) "binary", NULL }; static CONST84 char *statkindselectors[] = { (char *) "used", (char *) "available", (char *) "freed", (char *) "allocated", NULL }; int T4Storage::Statistic(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Space sp; e4_SpaceStat st; int v; /* * Expecting exactly two arguments. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage statistic space kind"); return TCL_ERROR; } /* * Determine which space kind we want a statistic about. */ if (Tcl_GetIndexFromObj(interp, objv[0], (CONST84 char **) statspaceselectors, (char *) "space", 0, (int *) &sp) != TCL_OK) { return TCL_ERROR; } /* * Determine which statistic we want about that space. */ if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **) statkindselectors, (char *) "kind", 0, (int *) &st) != TCL_OK) { return TCL_ERROR; } /* * Retrieve the actual statistic. */ if (!s.GetStatistic(sp, st, v)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot retrieve statistic \"", Tcl_GetString(objv[1]), "\" about space \"", Tcl_GetString(objv[0]), "\" in storage ", GetName(), NULL); return TCL_ERROR; } Tcl_SetIntObj(Tcl_GetObjResult(interp), v); return TCL_OK; } /* * Get -- * * Get a TGraph entity identified by a given ID and kind string. * * Result: * A standard Tcl result. Upon success, the interpreter result * contains the name of the Tcl command to use to invoke * operations on the TGraph entity. * * Side effects: * May define a Tcl command for a newly exported TGraph entity. */ static CONST84 char *objectkindselectors[] = { (char *) "node", (char *) "vertex", (char *) "storage", NULL }; int T4Storage::Get(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int id; T4ObjectKindSelector oksel; e4_NodeUniqueID nuid; e4_VertexUniqueID vuid; e4_Node n; e4_Vertex v; T4Node *tnp; T4Vertex *tvp; Tcl_Obj *res; /* * Expecting exactly two arguments, the kind of the object to retrieve * and its ID. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage get objkind id"); return TCL_ERROR; } /* * Determine the kind of object to retrieve. */ if (Tcl_GetIndexFromObj(interp, objv[0], (CONST84 char **) objectkindselectors, (char *) "objkind", 0, (int *) &oksel) != TCL_OK) { return TCL_ERROR; } /* * Attempt to get the integer ID of the object to retrieve: */ if (Tcl_GetIntFromObj(interp, objv[1], &id) != TCL_OK) { return TCL_ERROR; } /* * Check that the storage is valid. */ if (!s.IsValid()) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid storage ", GetName(), NULL); return TCL_ERROR; } /* * Attempt to retrieve the object requested: */ switch (oksel) { case T4_OKSTORAGE: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't do \"$storage get storage ..", NULL); return TCL_ERROR; case T4_OKNODE: nuid.SetUniqueID(id, s); /* * If the node is already exported to Tcl, return its command name. */ tnp = GetNodeById(interp, nuid); if (tnp != NULL) { res = tnp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, tnp, interp); tnp->SetTclObject(res); } Tcl_SetObjResult(interp, res); return TCL_OK; } /* * Not exported yet. Retrieve the e4_Node for this ID, then export * the corresponding Tcl command. */ if ((!s.GetNodeFromID(nuid, n)) || (!n.IsValid())) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid node id ", Tcl_GetString(objv[1]), NULL); return TCL_ERROR; } tnp = new T4Node(n, this); StoreNode(interp, tnp, nuid); res = tnp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, tnp, interp); tnp->SetTclObject(res); } Tcl_SetObjResult(interp, res); return TCL_OK; case T4_OKVERTEX: vuid.SetUniqueID(id, s); /* * If the vertex is already exported to Tcl, return its command name. */ tvp = GetVertexById(interp, vuid); if (tvp != NULL) { res = tvp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(vertexExt, tvp, interp); tvp->SetTclObject(res); } Tcl_SetObjResult(interp, res); return TCL_OK; } /* * Not yet exported. Retrieve the e4_Vertex for this ID, then export * its Tcl command. */ if ((!s.GetVertexFromID(vuid, v)) || (!v.IsValid())) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid vertex id ", Tcl_GetString(objv[1]), NULL); return TCL_ERROR; } tvp = new T4Vertex(v, this); StoreVertex(interp, tvp, vuid); res = tvp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(vertexExt, tvp, interp); tvp->SetTclObject(res); } Tcl_SetObjResult(interp, res); return TCL_OK; } /* * If we get here there's an internal error, because this code should * be unreachable. */ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "internal error: \"$storage get\": unreachable", " code", NULL); return TCL_ERROR; } /* * Share -- * * Share this storage with another interpreter. * * Results: * A standard Tcl result. Upon success, the interpreter result will * contain the name of the storage in the other interpreter. * * Side effects: * The other interpreter (a slave of this one) will have access to * the storage. */ int T4Storage::Share(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_Interp *slave; /* * If the storage is not accessible in this interpreter, error out. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage \"", GetName(), "\" is not available in this interpreter", NULL); return TCL_ERROR; } /* * Expecting exactly two arguments, the name of the interpreter to * share this storage with, and the name of the global variable in * that interpreter to store the name of the storage into. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage share interp globalvar"); return TCL_ERROR; } /* * Find the slave interpreter. */ slave = Tcl_GetSlave(interp, Tcl_GetString(objv[0])); if (slave == NULL) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "$storage share", ": could not find interpreter \"", Tcl_GetString(objv[2]), "\"", (char *) NULL); return TCL_ERROR; } /* * Check if the storage is already accessible in the slave. If not, then * make it available in the slave. */ spp = GetStoragePerInterp(slave); if (spp == NULL) { /* * Export it as a command. */ if (T4Graph_MakeStorageCommand(slave, this) == TCL_ERROR) { return TCL_ERROR; } /* * Register the storage in the slave. */ RegisterStoragePerInterp(slave); /* * Ensure the slave interpreter is set up to close the storages * that are registered in it when the interpreter is deleted. */ T4Graph_RegisterInterp(slave); } /* * Now assign the storage name to the designated global variable. */ Tcl_SetVar(slave, Tcl_GetString(objv[1]), GetName(), TCL_GLOBAL_ONLY); /* * And leave the name of the new storage in this interpreter result. */ Tcl_SetStringObj(Tcl_GetObjResult(interp), GetName(), -1); return TCL_OK; } /* * Callback -- * * Add or remove a callback for events of interest while running * a TGraph application. * * Results: * A standard Tcl result. Upon success, when a callback is added, * the interpreter result contains the token to use when cancelling * that callback later. Upon success, when a callback is removed, * the interpreter result is empty. * * Side effects: * Subsequently, when the specified event happens, a callback may * occur or may stop to occur. */ static CONST84 char *callbackeventselectors[] = { (char *) "add", (char *) "detach", (char *) "attach", (char *) "modify", (char *) "change", NULL }; static CONST84 char *callbackactionselectors[] = { (char *) "add", (char *) "delete", (char *) "get", (char *) "set", (char *) "kind", (char *) "count", (char *) "exists", NULL }; int T4Storage::Callback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4CallbackActionSelector cbas; /* * Expecting at least two arguments. */ if (objc < 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage callback action arg ?arg ...?"); return TCL_ERROR; } /* * Determine what kind of action (add or delete a callback) is requested. */ if (Tcl_GetIndexFromObj(interp, objv[0], (CONST84 char **) callbackactionselectors, (char *) "action", 0, (int *) &cbas) != TCL_OK) { return TCL_ERROR; } switch (cbas) { case T4_CBASADD: return CBAddCallback(interp, objc-1, objv+1); case T4_CBASDEL: return CBDelCallback(interp, objc-1, objv+1); case T4_CBASGET: return CBGetCallback(interp, objc-1, objv+1); case T4_CBASSET: return CBSetCallback(interp, objc-1, objv+1); case T4_CBASKND: return CBKindCallback(interp, objc-1, objv+1); case T4_CBASCNT: return CBCountCallback(interp, objc-1, objv+1); case T4_CBASHAS: return CBHasCallback(interp, objc-1, objv+1); } /* * Some compilers (VC++) insist on this... */ return TCL_ERROR; } /* * Configure -- * * Configure options for a storage, or retrieve one or all * option settings for a storage. * * Results: * A standard Tcl result. Upon success, the interpreter result is * empty when options are configured. When behaviors are retrieved, * upon success the interpreter result contains a list of alternating * option names and values. * * Side effects: * May modify the behavior of this storage according to the options * being configured in the call. */ int T4Storage::Configure(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting either zero, one or an even numbered >= 2 arguments. */ if ((objc != 0) && (objc != 1) && ((objc % 2) != 0)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage configure ?opt? ?val? ?opt val ..?"); return TCL_ERROR; } if (objc == 0) { return GetStorageOptions(interp); } if (objc == 1) { return GetStorageOption(interp, objv[0]); } return SetStorageOptions(interp, objc, objv); } /* * Helper functions to manage callbacks. */ int T4Storage::CBAddCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); T4CallbackRecord *r, *savedr; Tcl_HashEntry *ePtr; int isnew; T4ObjectKindSelector cbos; T4CallbackEventSelector cbes; /* * Expecting three arguments. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "storage callback add objsel eventsel script"); return TCL_ERROR; } /* * Attempt to parse the object selector. */ if (Tcl_GetIndexFromObj(interp, objv[0], (CONST84 char **) objectkindselectors, (char *) "objsel", 0, (int *) &cbos) != TCL_OK) { return TCL_ERROR; } /* * Attempt to parse the event selector. */ if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **) callbackeventselectors, (char *) "eventsel", 0, (int *) &cbes) != TCL_OK){ return TCL_ERROR; } /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage ", GetName(), " is unavailable in this interpreter", NULL); return TCL_ERROR; } r = new T4CallbackRecord; r->interp = interp; r->storage = this; switch (cbos) { case T4_OKSTORAGE: switch (cbes) { case T4_CBESCHG: if (spp->cbchgstorage < 0) { spp->cbchgstorage = 0; } if (spp->cbchgstorage == 0) { savedr = new T4CallbackRecord; savedr->interp = interp; savedr->storage = this; savedr->kind = E4_ECCHANGESTG; spp->cbChgStorageRecord = savedr; s.DeclareCallback(E4_ECCHANGESTG, StorageChangeCallbackFn, (void *) savedr); } spp->cbchgstorage++; r->kind = E4_ECCHANGESTG; break; case T4_CBESMOD: case T4_CBESADD: case T4_CBESATT: case T4_CBESDET: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback operation on storage", NULL); return TCL_ERROR; } break; case T4_OKNODE: switch (cbes) { case T4_CBESMOD: if (spp->cbmodnode < 0) { spp->cbmodnode = 0; } spp->cbmodnode++; r->kind = E4_ECMODNODE; break; case T4_CBESADD: if (spp->cbaddnode < 0) { spp->cbaddnode = 0; } if (spp->cbaddnode == 0) { savedr = new T4CallbackRecord; savedr->interp = interp; savedr->storage = this; savedr->kind = E4_ECADDNODE; spp->cbAddNodeRecord = savedr; s.DeclareCallback(E4_ECADDNODE, NodeAddCallbackFn, (void *) savedr); } spp->cbaddnode++; r->kind = E4_ECADDNODE; break; case T4_CBESDET: if (spp->cbdetnode < 0) { spp->cbdetnode = 0; } if (spp->cbdetnode == 0) { savedr = new T4CallbackRecord; savedr->interp = interp; savedr->storage = this; savedr->kind = E4_ECDETNODE; spp->cbDetNodeRecord = savedr; s.DeclareCallback(E4_ECDETNODE, NodeDetCallbackFn, (void *) savedr); } spp->cbdetnode++; r->kind = E4_ECDETNODE; break; case T4_CBESATT: if (spp->cbattnode < 0) { spp->cbattnode = 0; } if (spp->cbattnode == 0) { savedr = new T4CallbackRecord; savedr->interp = interp; savedr->storage = this; savedr->kind = E4_ECATTNODE; spp->cbAttNodeRecord = savedr; s.DeclareCallback(E4_ECATTNODE, NodeAttCallbackFn, (void *) savedr); } spp->cbattnode++; r->kind = E4_ECATTNODE; break; case T4_CBESCHG: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback operation on node", NULL); return TCL_ERROR; } break; case T4_OKVERTEX: switch (cbes) { case T4_CBESADD: if (spp->cbaddvertex < 0) { spp->cbaddvertex = 0; } if (spp->cbaddvertex == 0) { savedr = new T4CallbackRecord; savedr->interp = interp; savedr->storage = this; savedr->kind = E4_ECADDVERTEX; spp->cbAddVertexRecord = savedr; s.DeclareCallback(E4_ECADDVERTEX, VertexAddCallbackFn, (void *) savedr); } spp->cbaddvertex++; r->kind = E4_ECADDVERTEX; break; case T4_CBESDET: if (spp->cbdetvertex < 0) { spp->cbdetvertex = 0; } if (spp->cbdetvertex == 0) { savedr = new T4CallbackRecord; savedr->interp = interp; savedr->storage = this; savedr->kind = E4_ECDETVERTEX; spp->cbDetVertexRecord = savedr; s.DeclareCallback(E4_ECDETVERTEX, VertexDetCallbackFn, (void *) savedr); } spp->cbdetvertex++; r->kind = E4_ECDETVERTEX; break; case T4_CBESATT: if (spp->cbattvertex < 0) { spp->cbattvertex = 0; } if (spp->cbattvertex == 0) { savedr = new T4CallbackRecord; savedr->interp = interp; savedr->storage = this; savedr->kind = E4_ECATTVERTEX; spp->cbAttVertexRecord = savedr; s.DeclareCallback(E4_ECATTVERTEX, VertexAttCallbackFn, (void *) savedr); } spp->cbattvertex++; r->kind = E4_ECATTVERTEX; break; case T4_CBESMOD: if (spp->cbmodvertex < 0) { spp->cbmodvertex = 0; } spp->cbmodvertex++; r->kind = E4_ECMODVERTEX; break; case T4_CBESCHG: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback operation on vertex", NULL); return TCL_ERROR; } break; } /* * Record the script. */ ePtr = Tcl_CreateHashEntry(spp->callbacks, (char *) r, &isnew); Tcl_SetHashValue(ePtr, objv[2]); Tcl_IncrRefCount(objv[2]); Tcl_SetIntObj(Tcl_GetObjResult(interp), (int) r); return TCL_OK; } int T4Storage::CBDelCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *ePtr; int i; T4CallbackRecord *r; Tcl_Obj *o; /* * Expecting one argument, the callback token. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage callback del callbacktoken"); return TCL_ERROR; } /* * Extract the callback record. */ if (Tcl_GetIntFromObj(interp, objv[0], &i) != TCL_OK) { return TCL_ERROR; } r = (T4CallbackRecord *) i; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage ", GetName(), " is unavailable in this interpreter", NULL); return TCL_ERROR; } /* * Unrecord this script. */ ePtr = E4_FINDHASHENTRY(spp->callbacks, (char *) r); if (ePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback token ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } o = (Tcl_Obj *) Tcl_GetHashValue(ePtr); Tcl_DecrRefCount(o); /* * Delete the hash entry. */ Tcl_DeleteHashEntry(ePtr); /* * Now figure out if this was the last recorded Tcl-level callback * of this kind. If so, then remove the e4Graph-level callback. */ switch (r->kind) { case E4_ECADDNODE: spp->cbaddnode--; if (spp->cbaddnode <= 0) { s.DeleteCallback(E4_ECADDNODE, NodeAddCallbackFn, (void *) spp->cbAddNodeRecord); delete spp->cbAddNodeRecord; spp->cbAddNodeRecord = NULL; } break; case E4_ECDETNODE: spp->cbdetnode--; if (spp->cbdetnode <= 0) { s.DeleteCallback(E4_ECDETNODE, NodeDetCallbackFn, (void *) spp->cbDetNodeRecord); delete spp->cbDetNodeRecord; spp->cbDetNodeRecord = NULL; } break; case E4_ECATTNODE: spp->cbattnode--; if (spp->cbattnode <= 0) { s.DeleteCallback(E4_ECATTNODE, NodeAttCallbackFn, (void *) spp->cbAttNodeRecord); delete spp->cbAttNodeRecord; spp->cbAttNodeRecord = NULL; } break; case E4_ECMODNODE: spp->cbmodnode--; if (spp->cbmodnode < 0) { spp->cbmodnode = 0; } break; case E4_ECADDVERTEX: spp->cbaddvertex--; if (spp->cbaddvertex <= 0) { s.DeleteCallback(E4_ECADDVERTEX, VertexAddCallbackFn, (void *) spp->cbAddVertexRecord); delete spp->cbAddVertexRecord; spp->cbAddVertexRecord = NULL; } break; case E4_ECDETVERTEX: spp->cbdetvertex--; if (spp->cbdetvertex <= 0) { s.DeleteCallback(E4_ECDETVERTEX, VertexDetCallbackFn, (void *) spp->cbDetVertexRecord); delete spp->cbDetVertexRecord; spp->cbDetVertexRecord = NULL; } break; case E4_ECATTVERTEX: spp->cbattvertex--; if (spp->cbattvertex <= 0) { s.DeleteCallback(E4_ECATTVERTEX, VertexAttCallbackFn, (void *) spp->cbAttVertexRecord); delete spp->cbAttVertexRecord; spp->cbAttVertexRecord = NULL; } break; case E4_ECMODVERTEX: spp->cbmodvertex--; if (spp->cbmodvertex < 0) { spp->cbmodvertex = 0; } break; case E4_ECCHANGESTG: spp->cbchgstorage--; if (spp->cbchgstorage <= 0) { s.DeleteCallback(E4_ECCHANGESTG, StorageChangeCallbackFn, (void *) spp->cbChgStorageRecord); delete spp->cbChgStorageRecord; spp->cbChgStorageRecord = NULL; } } /* * Finally, delete the callback token. */ delete r; return TCL_OK; } int T4Storage::CBGetCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *ePtr; int i; T4CallbackRecord *r; Tcl_Obj *o; /* * Expecting one argument, the callback token. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage callback get callbacktoken"); return TCL_ERROR; } /* * Extract the callback record. */ if (Tcl_GetIntFromObj(interp, objv[0], &i) != TCL_OK) { return TCL_ERROR; } r = (T4CallbackRecord *) i; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage ", GetName(), " is unavailable in this interpreter", NULL); return TCL_ERROR; } /* * See if we have such a record. */ ePtr = E4_FINDHASHENTRY(spp->callbacks, (char *) r); if (ePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback token ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } o = (Tcl_Obj *) Tcl_GetHashValue(ePtr); /* * Now return the actual script. */ Tcl_SetObjResult(interp, o); return TCL_OK; } int T4Storage::CBSetCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *ePtr; int i; T4CallbackRecord *r; Tcl_Obj *o; /* * Expecting two argument, the callback token and the new script. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage callback get callbacktoken"); return TCL_ERROR; } /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage ", GetName(), " is unavailable in this interpreter", NULL); return TCL_ERROR; } /* * Extract the callback record. */ if (Tcl_GetIntFromObj(interp, objv[0], &i) != TCL_OK) { return TCL_ERROR; } r = (T4CallbackRecord *) i; /* * See if we have such a record. */ ePtr = E4_FINDHASHENTRY(spp->callbacks, (char *) r); if (ePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback token ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } o = (Tcl_Obj *) Tcl_GetHashValue(ePtr); /* * Discard old script. */ Tcl_DecrRefCount(o); /* * Install new script. */ E4_SETHASHVALUE(ePtr, objv[1]); Tcl_IncrRefCount(objv[1]); /* * Now return the callback token, as we do when it was created. */ Tcl_SetObjResult(interp, objv[0]); return TCL_OK; } int T4Storage::CBKindCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *ePtr; int i; T4CallbackRecord *r; char buffer[128]; /* * Expecting one argument, the callback token. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage callback kind callbacktoken"); return TCL_ERROR; } /* * Extract the callback record. */ if (Tcl_GetIntFromObj(interp, objv[0], &i) != TCL_OK) { return TCL_ERROR; } r = (T4CallbackRecord *) i; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage ", GetName(), " is unavailable in this interpreter", NULL); return TCL_ERROR; } /* * See if we have such a record. */ ePtr = E4_FINDHASHENTRY(spp->callbacks, (char *) r); if (ePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback token ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } switch (r->kind) { case E4_ECADDNODE: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "node add", NULL); break; case E4_ECADDVERTEX: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "vertex add", NULL); break; case E4_ECDETNODE: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "node detach", NULL); break; case E4_ECATTNODE: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "node attach", NULL); break; case E4_ECMODNODE: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "node modify", NULL); break; case E4_ECDETVERTEX: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "vertex detach", NULL); break; case E4_ECATTVERTEX: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "vertex attach", NULL); break; case E4_ECMODVERTEX: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "vertex modify", NULL); break; case E4_ECCHANGESTG: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage change", NULL); break; default: /* * User defined event code. */ sprintf(buffer, "userdefined %d", r->kind); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), buffer, NULL); break; } return TCL_OK; } int T4Storage::CBCountCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); T4ObjectKindSelector cbos; T4CallbackEventSelector cbes; /* * Expecting two arguments, an object selector and an event selector. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage callback count objsel eventsel"); return TCL_ERROR; } /* * Attempt to parse the object selector. */ if (Tcl_GetIndexFromObj(interp, objv[0], (CONST84 char **) objectkindselectors, (char *) "objsel", 0, (int *) &cbos) != TCL_OK) { return TCL_ERROR; } /* * Attempt to parse the event selector. */ if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **) callbackeventselectors, (char *) "eventsel", 0, (int *) &cbes) != TCL_OK){ return TCL_ERROR; } /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage ", GetName(), " is unavailable in this interpreter", NULL); return TCL_ERROR; } switch (cbos) { case T4_OKNODE: switch (cbes) { case T4_CBESMOD: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbmodnode); break; case T4_CBESADD: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbaddnode); break; case T4_CBESDET: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbdetnode); break; case T4_CBESATT: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbattnode); break; case T4_CBESCHG: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback operation on node", NULL); return TCL_ERROR; } break; case T4_OKVERTEX: switch (cbes) { case T4_CBESMOD: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbmodvertex); break; case T4_CBESADD: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbaddvertex); break; case T4_CBESDET: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbdetvertex); break; case T4_CBESATT: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbattvertex); break; case T4_CBESCHG: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback operation on vertex", NULL); return TCL_ERROR; } break; case T4_OKSTORAGE: switch (cbes) { case T4_CBESMOD: case T4_CBESADD: case T4_CBESDET: case T4_CBESATT: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid callback operation on storage", NULL); return TCL_ERROR; case T4_CBESCHG: Tcl_SetIntObj(Tcl_GetObjResult(interp), spp->cbchgstorage); break; } break; } return TCL_OK; } int T4Storage::CBHasCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); T4ObjectKindSelector cbos; T4CallbackEventSelector cbes; /* * Expecting two arguments, an object selector and an event selector. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$storage callback exists objsel eventsel"); return TCL_ERROR; } /* * Attempt to parse the object selector. */ if (Tcl_GetIndexFromObj(interp, objv[0], (CONST84 char **) objectkindselectors, (char *) "objsel", 0, (int *) &cbos) != TCL_OK) { return TCL_ERROR; } /* * Attempt to parse the event selector. */ if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **) callbackeventselectors, (char *) "eventsel", 0, (int *) &cbes) != TCL_OK){ return TCL_ERROR; } /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "storage ", GetName(), " is unavailable in this interpreter", NULL); return TCL_ERROR; } switch (cbos) { case T4_OKNODE: switch (cbes) { case T4_CBESMOD: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbmodnode > 0) ? 1 : 0); break; case T4_CBESADD: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbaddnode > 0) ? 1 : 0); break; case T4_CBESDET: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbdetnode > 0) ? 1 : 0); break; case T4_CBESATT: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbattnode > 0) ? 1 : 0); break; case T4_CBESCHG: Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); break; } break; case T4_OKVERTEX: switch (cbes) { case T4_CBESMOD: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbmodvertex > 0) ? 1 : 0); break; case T4_CBESADD: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbaddvertex > 0) ? 1 : 0); break; case T4_CBESDET: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbdetvertex > 0) ? 1 : 0); break; case T4_CBESATT: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbattvertex > 0) ? 1 : 0); break; case T4_CBESCHG: Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); break; } break; case T4_OKSTORAGE: switch (cbes) { case T4_CBESMOD: case T4_CBESADD: case T4_CBESDET: case T4_CBESATT: Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); break; case T4_CBESCHG: Tcl_SetIntObj(Tcl_GetObjResult(interp), (spp->cbchgstorage > 0) ? 1 : 0); break; } break; } return TCL_OK; } void T4Storage::AddNodeCallback(Tcl_Interp *interp, e4_Node n) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); e4_NodeUniqueID nuid; T4Node *np; Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { return; } /* * Ensure the node is exported to Tcl. */ if (!n.GetUniqueID(nuid)) { return; } np = GetNodeById(interp, nuid); if (np == NULL) { np = new T4Node(n, this); StoreNode(interp, np, nuid); } res = np->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, np, interp); np->SetTclObject(res); } Tcl_IncrRefCount(res); /* * Iterate over all callbacks and invoke the ones for adding nodes. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECADDNODE) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } void T4Storage::DetNodeCallback(Tcl_Interp *interp, e4_Node n) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); e4_NodeUniqueID nuid; T4Node *np; Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { return; } /* * Ensure the node is exported to Tcl, if not, punt. */ if (!n.GetUniqueID(nuid)) { return; } np = GetNodeById(interp, nuid); if (np == NULL) { return; } res = np->GetTclObject(); if (res == NULL) { return; } Tcl_IncrRefCount(res); /* * Iterate over all callbacks and invoke the ones for deleting nodes. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECDETNODE) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } void T4Storage::AttNodeCallback(Tcl_Interp *interp, e4_Node n) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); e4_NodeUniqueID nuid; T4Node *np; Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { return; } /* * Ensure the node is exported to Tcl, if not, punt. */ if (!n.GetUniqueID(nuid)) { return; } np = GetNodeById(interp, nuid); if (np == NULL) { return; } res = np->GetTclObject(); if (res == NULL) { return; } Tcl_IncrRefCount(res); /* * Iterate over all callbacks and invoke the ones for deleting nodes. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECATTNODE) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } void T4Storage::AddVertexCallback(Tcl_Interp *interp, e4_Vertex v) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); e4_VertexUniqueID vuid; T4Vertex *vp; Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { return; } /* * Ensure the vertex is exported to Tcl. */ if (!v.GetUniqueID(vuid)) { return; } vp = GetVertexById(interp, vuid); if (vp == NULL) { vp = new T4Vertex(v, this); StoreVertex(interp, vp, vuid); } res = vp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(vertexExt, vp, interp); vp->SetTclObject(res); } Tcl_IncrRefCount(res); /* * Iterate over all callbacks and invoke the ones for adding vertices. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECADDVERTEX) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } void T4Storage::DetVertexCallback(Tcl_Interp *interp, e4_Vertex v) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); e4_VertexUniqueID vuid; T4Vertex *vp; Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { return; } /* * Ensure the vertex is exported to Tcl, if not, punt. */ if (!v.GetUniqueID(vuid)) { return; } vp = GetVertexById(interp, vuid); if (vp == NULL) { return; } res = vp->GetTclObject(); if (res == NULL) { return; } Tcl_IncrRefCount(res); /* * Iterate over all callbacks and invoke the ones for deleting vertices. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECDETVERTEX) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } void T4Storage::AttVertexCallback(Tcl_Interp *interp, e4_Vertex v) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); e4_VertexUniqueID vuid; T4Vertex *vp; Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; /* * If the storage is unavailable in this interpreter, punt. */ if (spp == NULL) { return; } /* * Ensure the vertex is exported to Tcl, if not, punt. */ if (!v.GetUniqueID(vuid)) { return; } vp = GetVertexById(interp, vuid); if (vp == NULL) { return; } res = vp->GetTclObject(); if (res == NULL) { return; } Tcl_IncrRefCount(res); /* * Iterate over all callbacks and invoke the ones for deleting vertices. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECATTVERTEX) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } /* * Special, always-on callbacks for vertex and node modification. These * methods do some bookkeeping before calling any Tcl scripts registered * for these callbacks. */ void T4Storage::ModNodeCallback(T4StoragePerInterp *spp, e4_Node n, e4_ModNodeEventReason cbr) { Tcl_Interp *interp = spp->interp; e4_NodeUniqueID nuid; T4Node *np; Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; /* * Ensure the node is exported to Tcl, if not, punt. */ if (!n.GetUniqueID(nuid)) { return; } np = GetNodeById(interp, nuid); if (np == NULL) { return; } res = np->GetTclObject(); if (res == NULL) { return; } Tcl_IncrRefCount(res); /* * Iterate over all callbacks and invoke the ones for deleting nodes. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECMODNODE) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } void T4Storage::ModVertexCallback(T4StoragePerInterp *spp, e4_Vertex v, e4_ModVertexEventReason cbr) { Tcl_Interp *interp = spp->interp; e4_VertexUniqueID vuid; T4Vertex *vp; Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; /* * Ensure the vertex is exported to Tcl. If not, punt. */ if (!v.GetUniqueID(vuid)) { return; } vp = GetVertexById(interp, vuid); if (vp == NULL) { return; } res = vp->GetTclObject(); if (res == NULL) { return; } Tcl_IncrRefCount(res); /* * If the vertex's value was modified, flush the state * associated with this vertex. */ if (cbr == E4_ERMVMODVALUE) { spp->storage->ClearVertexStoredState(interp, v); } /* * Iterate over all callbacks and invoke the ones for deleting vertices. */ for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECMODVERTEX) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } void T4Storage::ChangeStorageCallback(Tcl_Interp *interp) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); Tcl_HashEntry *ePtr; Tcl_HashSearch search; T4CallbackRecord *r; Tcl_Obj *res; Tcl_Obj **objv, **newobjv; int objc, i, status; res = Tcl_NewObj(); Tcl_SetStringObj(res, GetName(), -1); Tcl_IncrRefCount(res); for (ePtr = Tcl_FirstHashEntry(spp->callbacks, &search); ePtr != NULL; ePtr = Tcl_NextHashEntry(&search)) { r = (T4CallbackRecord *) Tcl_GetHashKey(spp->callbacks, ePtr); if (r->kind != E4_ECCHANGESTG) { continue; } Tcl_ResetResult(interp); if (Tcl_ListObjGetElements(interp, (Tcl_Obj *) Tcl_GetHashValue(ePtr), &objc, &objv) != TCL_OK) { Tcl_DecrRefCount(res); return; } newobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); for (i = 0; i < objc; i++) { newobjv[i] = objv[i]; } newobjv[objc] = res; status = Tcl_EvalObjv(interp, objc + 1, newobjv, 0); (void) Tcl_Free((char *) newobjv); if (status != TCL_OK) { Tcl_DecrRefCount(res); return; } } Tcl_DecrRefCount(res); Tcl_ResetResult(interp); } /* * Return the per-interpreter data structure for this storage for the given * interpreter. If not found, return NULL. */ T4StoragePerInterp * T4Storage::GetStoragePerInterp(Tcl_Interp *interp) { T4StoragePerInterp *spp; for (spp = spip; spp != NULL; spp = spp->next) { if (spp->interp == interp) { return spp; } } return NULL; } /* * Register the storage in the given interpreter, after ensuring * that the interpreter has a proper data association for registering * storages. */ void T4Storage::RegisterStoragePerInterp(Tcl_Interp *interp) { T4StoragePerInterp *spp = GetStoragePerInterp(interp); /* * If the storage is already available in the given interpreter, just * return. */ if (spp != NULL) { return; } /* * Not available yet, make a new record and link it into the list * of per-interpreter records. */ spp = new T4StoragePerInterp; /* * Store the storage it belongs to. */ spp->storage = this; /* * Initialize hash table storage for T4Graph objects that * were exported to Tcl: */ spp->exportedNodes = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(spp->exportedNodes, TCL_ONE_WORD_KEYS); spp->exportedVertices = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(spp->exportedVertices, TCL_ONE_WORD_KEYS); spp->storedProcs = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(spp->storedProcs, TCL_ONE_WORD_KEYS); spp->storedValues = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(spp->storedValues, TCL_ONE_WORD_KEYS); /* * Initialize the Tcl callback facility. */ spp->callbacks = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(spp->callbacks, TCL_ONE_WORD_KEYS); /* * Add per-storage-per-interp internal maintainence callbacks: */ s.DeclareCallback(E4_ECMODNODE, NodeModCallbackFn, (void *) spp); s.DeclareCallback(E4_ECMODVERTEX, VertexModCallbackFn, (void *) spp); /* * Initialize callback counters. */ spp->cbaddnode = 0; spp->cbaddvertex = 0; spp->cbdetnode = 0; spp->cbdetvertex = 0; spp->cbattnode = 0; spp->cbattvertex = 0; spp->cbmodnode = 0; spp->cbmodvertex = 0; spp->cbchgstorage = 0; spp->cbAddNodeRecord = NULL; spp->cbAddVertexRecord = NULL; spp->cbDetNodeRecord = NULL; spp->cbDetVertexRecord = NULL; spp->cbAttNodeRecord = NULL; spp->cbAttVertexRecord = NULL; spp->cbChgStorageRecord = NULL; spp->interp = interp; /* * Link the new record into the chain. */ spp->next = spip; spp->prev = NULL; if (spip != NULL) { spip->prev = spp; } spip = spp; } /* * This procedure unregisters this storage in the given interpreter. */ void T4Storage::UnregisterStoragePerInterp(Tcl_Interp *interp) { InternalClose(interp, true); Tcl_ResetResult(interp); } /* * These options are valid for $storage configure and tgraph::open: */ static CONST84 char *optionNames[] = { (char *) "-rwmode", (char *) "-driver", (char *) "-commitatclose", (char *) "-opengc", (char *) "-gcbeforecommit", (char *) "-autogc", (char *) "-bigprealloc", (char *) "-compactatclose", NULL }; typedef enum SOptions { SORWMode = 0, SODriver = 1, SOCommitAtClose = 2, SOOpenGC = 3, SOGCBeforeCommit = 4, SOAutoGC = 5, SOBigPrealloc = 6, SOCompactAtClose = 7 }; /* * Helper method to return all storage options for this storage. */ int T4Storage::GetStorageOptions(Tcl_Interp *interp) { int modes; Tcl_Obj *lobj; Tcl_ResetResult(interp); if (!s.IsValid()) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "$storage configure: invalid storage", NULL); return TCL_ERROR; } lobj = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("-driver", -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj(s.GetDriver(), -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("-rwmode", -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("rw", -1)); modes = s.GetState(); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("-commitatclose", -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewIntObj(((modes & E4_COMMITATCLOSE) == 0) ? 0 : 1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("-opengc", -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewIntObj(((modes & E4_OPENGC) == 0) ? 0 : 1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("-gcbeforecommit", -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewIntObj(((modes & E4_GCBEFORECOMMIT) == 0) ? 0 : 1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("-autogc", -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewIntObj(((modes & E4_AUTOGC) == 0) ? 0 : 1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("-bigprealloc", -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewIntObj(((modes & E4_BIGPREALLOC) == 0) ? 0 : 1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewStringObj("-compactatclose", -1)); Tcl_ListObjAppendElement(interp, lobj, Tcl_NewIntObj(((modes & E4_COMPACTATCLOSE) == 0) ? 0 : 1)); Tcl_SetObjResult(interp, lobj); return TCL_OK; } /* * Helper method to return a specific option value for this storage. */ int T4Storage::GetStorageOption(Tcl_Interp *interp, Tcl_Obj *opt) { SOptions index; int modes; /* * Check if the storage is valid. */ if (!s.IsValid()) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "$storage configure: invalid storage", NULL); return TCL_ERROR; } /* * See if the requested option is valid. */ if (Tcl_GetIndexFromObj(interp, opt, (CONST84 char **) optionNames, (char *) "option", 0, (int *) &index) != TCL_OK) { return TCL_ERROR; } /* * Return the relevant option: */ switch (index) { case SORWMode: Tcl_SetStringObj(Tcl_GetObjResult(interp), "rw", -1); break; case SODriver: Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) s.GetDriver(), -1); break; case SOCommitAtClose: modes = s.GetState(); Tcl_SetStringObj(Tcl_GetObjResult(interp), ((modes & E4_COMMITATCLOSE) == 0) ? (char *) "0" : (char *) "1", -1); break; case SOOpenGC: modes = s.GetState(); Tcl_SetStringObj(Tcl_GetObjResult(interp), ((modes & E4_OPENGC) == 0) ? (char *) "0" : (char *) "1", -1); break; case SOGCBeforeCommit: modes = s.GetState(); Tcl_SetStringObj(Tcl_GetObjResult(interp), ((modes & E4_GCBEFORECOMMIT) == 0) ? (char *) "0" : (char *) "1", -1); break; case SOAutoGC: modes = s.GetState(); Tcl_SetStringObj(Tcl_GetObjResult(interp), ((modes & E4_AUTOGC) == 0) ? (char *) "0" : (char *) "1", -1); break; case SOBigPrealloc: modes = s.GetState(); Tcl_SetStringObj(Tcl_GetObjResult(interp), ((modes & E4_BIGPREALLOC) == 0) ? (char *) "0" : (char *) "1", -1); break; case SOCompactAtClose: modes = s.GetState(); Tcl_SetStringObj(Tcl_GetObjResult(interp), ((modes & E4_COMPACTATCLOSE) == 0) ? (char *) "0" : (char *) "1", -1); break; } return TCL_OK; } /* * Parse storage options given to tgraph::open or $storage configure. * Returns 1 on success, 0 on failure. */ int T4Graph_ParseStorageOptions(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], T4StorageOptions *options) { int i, bv; SOptions index; for (i = 0; i < objc; i += 2) { /* * Parse the next option selector. */ if (Tcl_GetIndexFromObj(interp, objv[i], (CONST84 char **) optionNames, (char *) "option", i, (int *) &index) != TCL_OK) { return 0; } /* * Parse the option value. */ switch (index) { case SORWMode: Tcl_AppendResult(interp, "Cannot set read-only option -rwmode", NULL); return 0; case SODriver: Tcl_AppendResult(interp, "Cannot set read-only option -driver", NULL); return 0; case SOCommitAtClose: if (Tcl_GetBooleanFromObj(interp, objv[i+1], &bv) == TCL_ERROR) { return 0; } if (bv == 1) { options->modes |= E4_COMMITATCLOSE; } else { options->modes &= (~(E4_COMMITATCLOSE)); } break; case SOOpenGC: if (Tcl_GetBooleanFromObj(interp, objv[i+1], &bv) == TCL_ERROR) { return 0; } if (bv == 1) { options->modes |= E4_OPENGC; } else { options->modes &= (~(E4_OPENGC)); } break; case SOGCBeforeCommit: if (Tcl_GetBooleanFromObj(interp, objv[i+1], &bv) == TCL_ERROR) { return 0; } if (bv == 1) { options->modes |= E4_GCBEFORECOMMIT; } else { options->modes &= (~(E4_GCBEFORECOMMIT)); } break; case SOAutoGC: if (Tcl_GetBooleanFromObj(interp, objv[i+1], &bv) == TCL_ERROR) { return 0; } if (bv == 1) { options->modes |= E4_AUTOGC; } else { options->modes &= (~(E4_AUTOGC)); } break; case SOBigPrealloc: if (Tcl_GetBooleanFromObj(interp, objv[i+1], &bv) == TCL_ERROR) { return 0; } if (bv == 1) { options->modes |= E4_BIGPREALLOC; } else { options->modes &= (~(E4_BIGPREALLOC)); } break; case SOCompactAtClose: if (Tcl_GetBooleanFromObj(interp, objv[i+1], &bv) == TCL_ERROR) { return 0; } if (bv == 1) { options->modes |= E4_COMPACTATCLOSE; } else { options->modes &= (~(E4_COMPACTATCLOSE)); } break; } } return 1; } /* * Helper method to set configuration options. Only the behavior modes * can be set, the other options are silently ignored. */ int T4Storage::SetStorageOptions(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4StorageOptions options; /* * Check if the storage is valid. */ if (!s.IsValid()) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "$storage configure: invalid storage", NULL); return TCL_ERROR; } /* * Initialize the options to the current settings. */ options.modes = s.GetState(); /* * Parse all the options and their values. */ if (!T4Graph_ParseStorageOptions(interp, objc, objv, &options)) { return TCL_ERROR; } /* * Make the interpreter result contain a list describing the * previous values of all options. */ GetStorageOptions(interp); /* * Set the new behavior state. */ s.SetState(options.modes); /* * All done. */ return TCL_OK; }