/* * t4noderep.cpp -- * * This file contains the implementation of the class T4Node * 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 implement the T4Node GenObject extension data type: */ static void T4NodeCleanup(Tcl_Interp *interp, void *data, struct GO_Extension *extPtr); static int T4NodeInvoke(Tcl_Interp *interp, char *name, void *data, int objc, Tcl_Obj *CONST objv[], struct GO_Extension *extPtr); /* * The T4Node GenObject extension data structure itself: */ static struct GO_Extension nodeExtension = { (char *) "T4Node", 7, T4NodeCleanup, T4NodeInvoke, NULL, NULL }; /* * This pointer gives global access to the T4Node GenObject extension: */ struct GO_Extension *nodeExt = &nodeExtension; /* * The cleanup implementation: */ static void T4NodeCleanup(Tcl_Interp *interp, void *data, struct GO_Extension *extPtr) { T4Node *np = (T4Node *) data; np->CleanupInternal(interp); delete np; } /* * The various sub-commands for "t4graph::node": */ static CONST84 char *subCommands[] = { (char *) "kind", (char *) "vertexcount", (char *) "set", (char *) "add", (char *) "get", (char *) "setnode", (char *) "addnode", (char *) "getvertex", (char *) "movevertex", (char *) "detachvertex", (char *) "vertextype", (char *) "vertexrank", (char *) "vertexname", (char *) "renamevertex", (char *) "exists", (char *) "parent", (char *) "parentcount", (char *) "occurrencecount", (char *) "parentrank", (char *) "root", (char *) "isroot", (char *) "rankinparent", (char *) "nameinparent", (char *) "storage", (char *) "detach", (char *) "dispose", (char *) "isvalid", (char *) "isdetached", (char *) "method", (char *) "call", (char *) "foreach", (char *) "id", (char *) "userdata", (char *) "detachfirstvertexwithnode", (char *) "precache", (char *) NULL }; typedef enum NSubCommands { NKind = 0, NVertexCount, NSet, NAdd, NGet, NSetNode, NAddNode, NGetVertex, NMoveVertex, NDetachVertex, NVertexType, NVertexRank, NVertexName, NRenameVertex, NExists, NParent, NParentCount, NOccurrenceCount, NParentRank, NRoot, NIsRoot, NRankInParent, NNameInParent, NStorage, NDetach, NDispose, NIsValid, NIsDetached, NMethod, NCall, NForeach, NId, NUserData, NDetachVWN, NPreCache } NSubCommands; /* * T4NodeInvoke -- * * This procedure is invoked when a T4Node object is used as a command. * * Results: * A standard Tcl result. The interpreter result may contain various * results depending on the sub-command selected. * * Side effects: * Whatever the selected sub-command does. */ static int T4NodeInvoke(Tcl_Interp *interp, char *name, void *data, int objc, Tcl_Obj *CONST objv[], struct GO_Extension *extPtr) { T4Node *np; NSubCommands index; char buffer[512]; /* * There must be at least two arguments. */ if (objc < 2) { sprintf(buffer, "%s cmd ?arg ...?", name); Tcl_WrongNumArgs(interp, 0, NULL, buffer); return TCL_ERROR; } /* * The client data is the T4Node for this instance. */ np = (T4Node *) data; /* * Figure out what operation was requested. */ if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **) subCommands, (char *) "cmd", 0, (int *) &index) != TCL_OK) { return TCL_ERROR; } /* * Check if the node is valid (only return a Tcl error if it is invalid * and the operation requested is not "isvalid"). */ if ((np == NULL) || ((index != NIsValid) && (!np->IsValid()))) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), np->GetName(), ": node is invalid", NULL); return TCL_ERROR; } objc -= 2; objv += 2; /* * Invoke the requested operation: */ switch (index) { case NKind: Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) "node", -1); return TCL_OK; case NVertexCount: return np->VertexCount(interp, objc, objv); case NSet: return np->Set(interp, objc, objv); case NAdd: return np->Add(interp, objc, objv); case NGet: return np->Get(interp, objc, objv); case NSetNode: return np->SetNode(interp, objc, objv); case NAddNode: return np->AddNode(interp, objc, objv); case NGetVertex: return np->GetVertex(interp, objc, objv); case NMoveVertex: return np->MoveVertex(interp, objc, objv); case NDetachVertex: return np->DetachVertex(interp, objc, objv); case NVertexType: return np->VertexType(interp, objc, objv); case NVertexRank: return np->VertexRank(interp, objc, objv); case NVertexName: return np->VertexName(interp, objc, objv); case NRenameVertex: return np->RenameVertex(interp, objc, objv); case NExists: return np->Exists(interp, objc, objv); case NParent: return np->Parent(interp, objc, objv); case NParentCount: return np->ParentCount(interp, objc, objv); case NOccurrenceCount: return np->OccurrenceCount(interp, objc, objv); case NParentRank: return np->ParentRank(interp, objc, objv); case NRoot: return np->Root(interp, objc, objv); case NIsRoot: return np->IsRoot(interp, objc, objv); case NRankInParent: return np->RankInParent(interp, objc, objv); case NNameInParent: return np->NameInParent(interp, objc, objv); case NStorage: Tcl_SetStringObj(Tcl_GetObjResult(interp), np->GetStorage()->GetName(), -1); return TCL_OK; case NDetach: return np->Detach(interp, objc, objv); case NDispose: return np->Dispose(interp, objc, objv); case NIsValid: return np->IsValid(interp, objc, objv); case NIsDetached: return np->IsDetached(interp, objc, objv); case NMethod: return np->Method(interp, objc, objv); case NCall: return np->Call(interp, objc, objv); case NForeach: return np->Foreach(interp, objc, objv); case NId: return np->Id(interp, objc, objv); case NUserData: return np->UserData(interp, objc, objv); case NDetachVWN: return np->DetachFirstVertexWithNode(interp, objc, objv); case NPreCache: return np->PreCache(interp, objc, objv); default: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "NodeProc: unreachable code!", (char *) NULL); return TCL_ERROR; } } /* * Constructor: */ T4Node::T4Node(e4_Node nn, T4Storage *ss) { n = nn; s = ss; } /* * Destructor: */ T4Node::~T4Node() { n = invalidNode; s = NULL; } /* * Cleanup done before destructor: */ void T4Node::CleanupInternal(Tcl_Interp *interp) { e4_NodeUniqueID nuid; if (!n.GetUniqueID(nuid)) { return; } if (s != NULL) { s->RemoveNode(interp, nuid); } } /* * ExternalizeNode -- * * This procedure gives the caller access to the underlying * e4_Node object. * * Results: * None. * * Side effects: * The caller can now manipulate the underlying e4_Node * object directly. */ void T4Node::ExternalizeNode(e4_Node &nn) { nn = n; } /* * GetVertexRef -- * * Obtain an e4_Vertex from the name given, in the current node. * * Results: * TCL_OK if the vertex is found or createifnotfound is set true and * the vertex was created (with integer value 0). TCL_ERROR otherwise. * If successful, the output parameter v is set to the e4_Vertex of * the found vertex. * * Side effects: * May create a vertex if createifnotfound is set true. */ int T4Node::GetVertexRef(Tcl_Interp *interp, char *vn, bool createifnotfound, e4_Vertex &v) { e4_Storage ss; e4_NodeUniqueID nuid; e4_VertexUniqueID vuid; int index; char *fnp; T4VertexNameKinds vnk; n.GetStorage(ss); n.GetUniqueID(nuid); /* * Attempt to parse the vertex name. If this fails, the Tcl interpreter's * error message is already set so just return false. */ if (T4Graph_ParseVertexName(interp, vn, &fnp, &index, &vnk) == TCL_ERROR) { return TCL_ERROR; } if (vnk == T4VNK_INDEX) { if (!n.GetVertexRef(fnp, index, v)) { if (!createifnotfound || !n.AddVertexRef(fnp, E4_IOLAST, index, 0, v)) { goto error; } } } else { if (!n.GetVertexRefByRank(index, v)) { if (!createifnotfound || !n.AddVertexRef(fnp, E4_IOLAST, index, 0, v)) { goto error; } } } Tcl_ResetResult(interp); return TCL_OK; error: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "vertex named \"", vn, "\" not found", NULL); return TCL_ERROR; } /* * ObtainVertex -- * * Retrieve a T4Vertex given a vertex name. * * Results: * A pointer to a T4Vertex or NULL if the vertex can not be * obtained. In that case the interpreter result will contain * an error message. * * Side effects: * A new object command might be created for the vertex because * it is now exported to Tcl. */ T4Vertex * T4Node::ObtainVertex(Tcl_Interp *interp, char *vn, bool *created) { char *fn; int i; T4VertexNameKinds vnk; e4_Vertex f; e4_Storage ss; e4_VertexUniqueID vuid; e4_NodeUniqueID nuid; T4Vertex *fp; Tcl_Obj *res; /* * Parse the name of the vertex. */ if (T4Graph_ParseVertexName(interp, vn, &fn, &i, &vnk) == TCL_ERROR) { return NULL; } if (vnk == T4VNK_INDEX) { if ((!n.GetVertexRef(fn, i, f)) || (!f.IsValid())) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can not retrieve vertex ", vn, " in node ", GetName(), NULL); return NULL; } } else { if ((!n.GetVertexRefByRank(i, f)) || (!f.IsValid())) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can not retrieve vertex of rank ", vn, " in node ", GetName(), NULL); return NULL; } } /* * Clean up the interpreter result left there by * T4Graph_ParseVertexName. */ Tcl_ResetResult(interp); /* * See if this vertex has already been exported to Tcl. */ fp = s->GetVertexById(interp, vuid); *created = false; /* * If this vertex has not yet been exported to Tcl, wrap it in * a new T4Vertex object and export it to Tcl. */ if (fp == NULL) { fp = new T4Vertex(f, s); s->StoreVertex(interp, fp, vuid); *created = true; } /* * Ensure the Tcl_Obj * for this internal representation exists, * and return it as the result. */ res = fp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(vertexExt, fp, interp); fp->SetTclObject(res); } /* * Finally return the obtained vertex. */ return fp; } /* **************************************************************************** * * The following methods implement Tcl sub-commands on a T4Node * object. * **************************************************************************** */ /* * VertexCount -- * * Returns the number of vertices in this node. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains an integer representing the number of vertices in * this node. * * Side effects: * None. */ int T4Node::VertexCount(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node vertexcount"); return TCL_ERROR; } /* * Check that the node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Return the number of vertices as an integer: */ Tcl_SetIntObj(Tcl_GetObjResult(interp), n.VertexCount()); return TCL_OK; } /* * The various (optional) type selector values for the T4Vertex::Set * operation. */ static char *typeSelectors[] = { (char *) "-int", (char *) "-double", (char *) "-string", (char *) "-node", (char *) "-binary", NULL }; typedef enum TSelector { TSInteger = 0, TSDouble, TSString, TSNode, TSBinary } TSelector; /* * SetAs -- * * Sets the value of a vertex to the supplied value converted to the * requested type, if possible. * * Results: * A standard Tcl result. * * Side effects: * May set the value of a vertex. T4Graph objects that were previously * accessible through this vertex may become inaccessible. */ int T4Node::SetAs(Tcl_Interp *interp, e4_Vertex v, Tcl_Obj *val, int rt) { TSelector reqtype = (TSelector) rt; int i; double d; char *sv; int len; T4Node *np; e4_Node nn; switch (reqtype) { case TSInteger: if (Tcl_GetIntFromObj(interp, val, &i) == TCL_ERROR) { return TCL_ERROR; } if (!v.Set(i)) { Tcl_AppendResult(interp, "could not set value of vertex ", v.Name(), NULL); return TCL_ERROR; } break; case TSDouble: if (Tcl_GetDoubleFromObj(interp, val, &d) == TCL_ERROR) { return TCL_ERROR; } if (!v.Set(d)) { Tcl_AppendResult(interp, "could not set value of vertex ", v.Name(), NULL); return TCL_ERROR; } break; case TSString: sv = Tcl_GetString(val); if (!v.Set(sv)) { Tcl_AppendResult(interp, "could not set value of vertex ", v.Name(), NULL); return TCL_ERROR; } break; case TSNode: np = (T4Node *) GO_GetInternalRep(val, nodeExt); if (np == NULL) { Tcl_AppendResult(interp, "could not retrieve node named ", Tcl_GetString(val), NULL); return TCL_ERROR; } np->ExternalizeNode(nn); if (!nn.IsValid()) { Tcl_AppendResult(interp, "node name ", Tcl_GetString(val), " is invalid", NULL); return TCL_ERROR; } if (!v.Set(nn)) { Tcl_AppendResult(interp, "could not set value of vertex ", v.Name(), NULL); return TCL_ERROR; } break; case TSBinary: sv = Tcl_GetStringFromObj(val, &len); if (!v.Set((void *) sv, len)) { Tcl_AppendResult(interp, "could not set value of vertex ", v.Name(), NULL); return TCL_ERROR; } break; default: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "invalid requested type for assignment to ", "vertex ", v.Name(), NULL); return TCL_ERROR; } Tcl_ResetResult(interp); return TCL_OK; } /* * Set -- * * Sets the value of an existing vertex in a node to a * new value. * * Results: * A standard Tcl result. * * Side effects: * May modify an existing vertex in the persistent storage. */ int T4Node::Set(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; TSelector index; T4Node *np; e4_Node nn; int i; double d; /* * Expecting two or three arguments. */ if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node set vertexspec value ?astype?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * See if the vertice we want exists. If not, create it. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), true, v) == TCL_ERROR) { return TCL_ERROR; } /* * If a specific value type is requested, handle it specially by * attempting to convert the supplied value to the requested type * before assigning it to the vertex. */ if (objc == 3) { if (Tcl_GetIndexFromObj(interp, objv[2], (CONST84 char **) typeSelectors, (char *) "typeselector", 0, (int *) &index) != TCL_OK) { return TCL_ERROR; } return SetAs(interp, v, objv[1], (int) index); } /* * If it's a node use that as the value. */ np = (T4Node *) GO_GetInternalRep(objv[1], nodeExt); if (np != NULL) { np->ExternalizeNode(nn); if (nn.IsValid()) { if (!v.Set(nn)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set value of vertex ", GetName(), NULL); return TCL_ERROR; } /* * Cannot cache nodes since this prevents them from propagating * detach to their nodes (they are referenced and thus their * vertices do not become detached). */ return TCL_OK; } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set vertex ", GetName(), " to invalid node", NULL); return TCL_ERROR; } } /* * See if we can get an integer. */ if (Tcl_GetIntFromObj(interp, objv[1], &i) == TCL_OK) { if (!v.Set(i)) { Tcl_AppendResult(interp, "could not set value of vertex ", GetName(), NULL); return TCL_ERROR; } s->SetVertexStoredObject(interp, v, objv[1]); return TCL_OK; } Tcl_ResetResult(interp); /* * Try to get a double value out of the given object. */ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) == TCL_OK) { if (!v.Set(d)) { Tcl_AppendResult(interp, "could not set value of vertex ", GetName(), NULL); return TCL_ERROR; } s->SetVertexStoredObject(interp, v, objv[1]); return TCL_OK; } Tcl_ResetResult(interp); /* * Last resort - set the value as a string. */ if (!v.Set(Tcl_GetString(objv[1]))) { Tcl_AppendResult(interp, "could not set value of vertex ", GetName(), NULL); return TCL_ERROR; } s->SetVertexStoredObject(interp, v, objv[1]); return TCL_OK; } /* * Add -- * * Adds a new vertex with a given value to this node. * * Results: * A standard Tcl result. * * Side effects: * May add a new vertex to this node in the persistent storage. */ int T4Node::Add(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; TSelector ts; Tcl_Obj *value; Tcl_Obj *astype; char *fn; e4_InsertOrder io; int rank = 0; bool rankgiven = false, done = false; int i, len; double d; e4_Node nn; T4Node *np; /* * Expecting three, four or five arguments. */ if ((objc != 3) && (objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node add vn io ?rank? val ?astype?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Get the vertex name: */ fn = Tcl_GetString(objv[0]); /* * Get the insertOrder. */ if (T4Graph_ParseInsertOrder(interp, objv[1], &io) == TCL_ERROR) { return TCL_ERROR; } /* * If the insert order is E4_IOLAST or E4_IOFIRST, then the next * argument is the value. Otherwise it is a rank. */ if ((io != E4_IOLAST) && (io != E4_IOFIRST)) { if (Tcl_GetIntFromObj(interp, objv[2], &rank) == TCL_ERROR) { return TCL_ERROR; } rankgiven = true; } /* * If a rank was given, the value is in objv[3], otherwise it is * in objv[2]. If present, the argument after that is a type selector * for the type of value to install. */ if (rankgiven) { value = objv[3]; astype = NULL; if (objc == 5) { astype = objv[4]; } } else { value = objv[2]; astype = NULL; if (objc == 4) { astype = objv[3]; } } /* * Attempt to use the type selector if given. */ if (astype != NULL) { if (Tcl_GetIndexFromObj(interp, astype, (CONST84 char **) typeSelectors, (char *) "typeselector", 0, (int *) &ts) != TCL_OK) { return TCL_ERROR; } switch (ts) { case TSInteger: if (Tcl_GetIntFromObj(interp, value, &i) == TCL_ERROR) { return TCL_ERROR; } if (!n.AddVertex(fn, io, rank, i)) { Tcl_AppendResult(interp, "can not add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } break; case TSDouble: if (Tcl_GetDoubleFromObj(interp, value, &d) == TCL_ERROR) { return TCL_ERROR; } if (!n.AddVertex(fn, io, rank, d)) { Tcl_AppendResult(interp, "can not add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } break; case TSString: if (!n.AddVertex(fn, io, rank, Tcl_GetString(value))) { Tcl_AppendResult(interp, "can not add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } break; case TSNode: np = (T4Node *) GO_GetInternalRep(value, nodeExt); if (np == NULL) { Tcl_AppendResult(interp, "could not retrieve node named ", Tcl_GetString(value), NULL); return TCL_ERROR; } np->ExternalizeNode(nn); if (!nn.IsValid()) { Tcl_AppendResult(interp, "node name ", np->GetName(), " is invalid", NULL); return TCL_ERROR; } if (!n.AddVertex(fn, io, rank, nn)) { Tcl_AppendResult(interp, "can not add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } break; case TSBinary: char *ss = Tcl_GetStringFromObj(value, &len); if (!n.AddVertex(fn, io, rank, (void *) ss, len)) { Tcl_AppendResult(interp, "can not add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } break; } } else { /* * If it is a Tcl object representing a node, then get the node * and assign it as the value of this vertex. */ np = (T4Node *) GO_GetInternalRep(value, nodeExt); if (np != NULL) { np->ExternalizeNode(nn); if ((!nn.IsValid()) || (!n.AddVertex(fn, io, rank, nn))) { Tcl_AppendResult(interp, "cannot add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } return TCL_OK; } /* * If it's an integer, use the value: */ Tcl_ResetResult(interp); if (Tcl_GetIntFromObj(interp, value, &i) == TCL_OK) { if (!n.AddVertex(fn, io, rank, i)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } return TCL_OK; } /* * If it's a double, use that value: */ Tcl_ResetResult(interp); if (Tcl_GetDoubleFromObj(interp, value, &d) == TCL_OK) { if (!n.AddVertex(fn, io, rank, d)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } return TCL_OK; } /* * Last resort - set the value as a string. */ Tcl_ResetResult(interp); if (!n.AddVertex(fn, io, rank, Tcl_GetString(value))) { Tcl_AppendResult(interp, "cannot add vertex ", fn, " to node ", GetName(), NULL); return TCL_ERROR; } } return TCL_OK; } /* * Get -- * * Retrieve the value of an existing vertex. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains an object representing the value of the requested * vertex. * * Side effects: * None. */ int T4Node::Get(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; T4Node *np; int ii; double ff; const void *bytes; int nbytes; const char *ss; e4_Node nn; e4_NodeUniqueID nuid; Tcl_Obj *res; /* * Expecting one argument. */ if ((objc != 1) && (objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node get vertexspec ?createval? ?astype?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * See if the vertex we want exists. If not, and a set argument is * supplied, create it with that value. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { /* * If a set argument (and an optional as-type) are supplied, * set the vertex (creating it in the process) and then try again. */ if (objc > 1) { Tcl_ResetResult(interp); if (Set(interp, objc, objv) == TCL_OK) { if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { return TCL_ERROR; } } else { return TCL_ERROR; } } else { return TCL_ERROR; } } /* * When we get here, v contains the vertex. First of all check if we * have a stored object for this vertex; if so, return that. */ res = s->GetVertexStoredObject(interp, v); if (res != NULL) { Tcl_SetObjResult(interp, res); return TCL_OK; } /* * No stored object for this vertex. Create a Tcl object that represents * the value and store it as the interpreter result. */ switch (v.Type()) { case E4_VTBINARY: if (!v.Get(bytes, nbytes)) { Tcl_AppendResult(interp, "cannot retrieve value of vertex ", v.Name(), NULL); return TCL_ERROR; } Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) bytes, nbytes); /* * Store the interpreter result as the stored object for this vertex. */ s->SetVertexStoredObject(interp, v, Tcl_GetObjResult(interp)); return TCL_OK; case E4_VTINT: if (!v.Get(ii)) { Tcl_AppendResult(interp, "cannot retrieve value of vertex ", v.Name(), NULL); return TCL_ERROR; } Tcl_SetIntObj(Tcl_GetObjResult(interp), ii); /* * Store the interpreter result as the stored object for this vertex. */ s->SetVertexStoredObject(interp, v, Tcl_GetObjResult(interp)); return TCL_OK; case E4_VTDOUBLE: if (!v.Get(ff)) { Tcl_AppendResult(interp, "cannot retrieve value of vertex ", v.Name(), NULL); return TCL_ERROR; } Tcl_SetDoubleObj(Tcl_GetObjResult(interp), (double) ff); /* * Store the interpreter result as the stored object for this vertex. */ s->SetVertexStoredObject(interp, v, Tcl_GetObjResult(interp)); return TCL_OK; case E4_VTSTRING: if (!v.Get(ss)) { Tcl_AppendResult(interp, "cannot retrieve value of vertex ", v.Name(), NULL); return TCL_ERROR; } Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) ss, -1); /* * Store the interpreter result as the stored object for this vertex. */ s->SetVertexStoredObject(interp, v, Tcl_GetObjResult(interp)); return TCL_OK; case E4_VTNODE: if (!v.Get(nn)) { Tcl_AppendResult(interp, "cannot retrieve value of vertex ", v.Name(), NULL); return TCL_ERROR; } (void) nn.GetUniqueID(nuid); np = s->GetNodeById(interp, nuid); if (np == NULL) { np = new T4Node(nn, s); s->StoreNode(interp, np, nuid); } /* * Ensure this node's internal representation has a Tcl_Obj * * associated with it, and set the interpreter result to that. */ res = np->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, np, interp); np->SetTclObject(res); } Tcl_SetObjResult(interp, res); /* * Do not want to set the vertex stored object if it's a node, * because that confuses detaching. */ return TCL_OK; default: Tcl_AppendResult(interp, "unreachable code!", NULL); return TCL_ERROR; } } /* * SetNode -- * * Sets the value of an existing vertex to a new node. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains the name by which the new node is known in Tcl. * * Side effects: * May create a new node in the persistent storage and may modify * the value of a vertex in the persistent storage. */ int T4Node::SetNode(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; e4_Node nn; e4_NodeUniqueID nuid; T4Node *np; Tcl_Obj *res; /* * Expecting one argument. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node setnode vertexspec"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * See if the vertice we want exists. If not, create it. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), true, v) == TCL_ERROR) { return TCL_ERROR; } /* * Attempt to set the vertex to a new node. */ if (!v.SetNode(nn)) { Tcl_AppendResult(interp, "could not set vertex ", GetName(), " to a new node", NULL); return TCL_ERROR; } /* * Create the new T4Node object and export it to Tcl. */ (void) nn.GetUniqueID(nuid); np = new T4Node(nn, s); s->StoreNode(interp, np, nuid); res = np->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, np, interp); np->SetTclObject(res); } Tcl_SetObjResult(interp, res); /* * Cannot cache nodes as this prevents their vertices from becoming * detached if the node is not otherwise referenced. */ return TCL_OK; } /* * AddNode -- * * Adds a new vertex with a node as its value, to this node. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains the name by which the new node is known in Tcl. * * Side effects: * May add a new vertex and a new node in the persistent storage. */ int T4Node::AddNode(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { char *fn; int rank = 0; e4_InsertOrder io; e4_Node nn; e4_Vertex vv; e4_NodeUniqueID nuid; T4Node *np; char buf[32]; Tcl_Obj *res; /* * Expecting two or three arguments. */ if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node addnode name io ?rank?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Retrieve the vertex name to add: */ fn = Tcl_GetString(objv[0]); /* * Get the insertOrder. */ if (T4Graph_ParseInsertOrder(interp, objv[1], &io) == TCL_ERROR) { return TCL_ERROR; } /* * If there are three arguments, the third is the requested rank: */ if ((objc == 3) && (Tcl_GetIntFromObj(interp, objv[2], &rank) == TCL_ERROR)) { return TCL_ERROR; } /* * Attempt to add the vertex and obtain the new node. */ if ((!n.AddNode(fn, io, rank, nn)) || (!nn.IsValid())) { sprintf(buf, "%d", rank); Tcl_AppendResult(interp, "can not add vertex ", fn, " at ", Tcl_GetString(objv[1]), ", offset ", buf, ", to node ", GetName(), NULL); return TCL_ERROR; } /* * If there was a node add callback then the node will already be * exported to Tcl. Otherwise add it. */ (void) nn.GetUniqueID(nuid); np = s->GetNodeById(interp, nuid); if (np == NULL) { np = new T4Node(nn, s); s->StoreNode(interp, np, nuid); } res = np->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, np, interp); np->SetTclObject(res); } Tcl_SetObjResult(interp, res); /* * Cannot cache nodes because this prevents them from propagating detach * to their vertices. */ return TCL_OK; } /* * GetVertex -- * * Export a T4Vertex object for the selected vertex to Tcl. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains the name by which the vertex is known in Tcl. * * Side effects: * None. */ int T4Node::GetVertex(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; e4_VertexUniqueID vuid; T4Vertex *vp; Tcl_Obj *res; /* * One, two or three arguments expected. */ if ((objc != 1) && (objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node getvertex vertexspec ?createval? ?astype?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * See if the vertex we want exists. If not, and a set argument is * supplied, create it with that value. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { /* * If a set argument (and an optional as-type) are supplied, * set the vertex (creating it in the process) and then try again. */ if (objc > 1) { Tcl_ResetResult(interp); if (Set(interp, objc, objv) == TCL_OK) { if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { return TCL_ERROR; } } else { return TCL_ERROR; } } else { return TCL_ERROR; } } /* * See if we already exported this vertex to Tcl. */ (void) v.GetUniqueID(vuid); vp = s->GetVertexById(interp, vuid); /* * If we did not export it, make a new T4Vertex and store it under * the ID obtained from the e4Vertex object. */ if (vp == NULL) { vp = new T4Vertex(v, s); s->StoreVertex(interp, vp, vuid); } /* * Ensure the vertex internal representation has a Tcl_Obj * * associated with it. */ res = vp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(vertexExt, vp, interp); vp->SetTclObject(res); } Tcl_SetObjResult(interp, res); return TCL_OK; } /* * MoveVertex -- * * Move a vertex identified by a vertex name to another location. * * Results: * A standard Tcl result. * * Side effects: * May move a vertex to another location in the persistent storage. */ int T4Node::MoveVertex(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4Vertex *fp; e4_Vertex f; e4_InsertOrder io; int offset = 0; char buf[32]; /* * Expecting two or three arguments. */ if ((objc != 3) && (objc != 2)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node movevertex vn io ?offset?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * The first argument is the vertex object to move. Obtain the T4Vertex * object out of it. */ fp = (T4Vertex *) GO_GetInternalRep(objv[0], vertexExt); /* * Obtain the enclosed e4_Vertex object. */ fp->ExternalizeVertex(f); if (!f.IsValid()) { Tcl_AppendResult(interp, "invalid vertex ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } /* * Parse the insertOrder. */ if (T4Graph_ParseInsertOrder(interp, objv[1], &io) == TCL_ERROR) { return TCL_ERROR; } /* * If there are three arguments, the third is a requested offset. */ if ((objc == 3) && (Tcl_GetIntFromObj(interp, objv[2], &offset) == TCL_ERROR)) { return TCL_ERROR; } /* * Attempt to move the vertex. */ if (!n.MoveVertex(f, io, offset)) { sprintf(buf, "%d", offset); Tcl_AppendResult(interp, "can not move vertex ", Tcl_GetString(objv[0]), " to ", Tcl_GetString(objv[1]), " ", buf, " in node ", GetName(), NULL); return TCL_ERROR; } return TCL_OK; } /* * DetachVertex -- * * Detach a given vertex from this node. * * Results: * A standard Tcl result. * * Side effects: * May delete a vertex from the persistent storage. */ int T4Node::DetachVertex(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { char *vn; char *fn; int i; T4VertexNameKinds vnk; /* * Expecting one argument. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node detachvertex vertexspec"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } vn = Tcl_GetString(objv[0]); /* * Attempt to parse the vertex name. */ if (T4Graph_ParseVertexName(interp, vn, &fn, &i, &vnk) == TCL_ERROR) { return TCL_ERROR; } Tcl_ResetResult(interp); /* * If its a rank spec, detach the vertex by rank. */ if (vnk == T4VNK_RANK) { if (n.DetachVertexByRank(i)) { return TCL_OK; } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown vertex rank ", vn, NULL); return TCL_ERROR; } /* * It's an indexed vertex name. Attempt to detach the vertex by index. */ if (n.DetachVertex(fn, i)) { return TCL_OK; } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown vertex \"", vn, "\"", NULL); return TCL_ERROR; } /* * VertexType -- * * Returns a string representing the type of the value stored in * a specified vertex. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains a string representing the type of the value stored * in the specified vertex. * * Side effects: * None. */ int T4Node::VertexType(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; /* * Expecting one argument. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node vertextype vertexspec"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * See if the vertice we want exists. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { return TCL_ERROR; } switch (v.Type()) { case E4_VTUNKNOWN: Tcl_AppendResult(interp, "could not retrieve type of vertex ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; case E4_VTNODE: Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) "node", -1); return TCL_OK; case E4_VTINT: Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) "int", -1); return TCL_OK; case E4_VTDOUBLE: Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) "double", -1); return TCL_OK; case E4_VTSTRING: Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) "string", -1); return TCL_OK; case E4_VTBINARY: Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) "binary", -1); return TCL_OK; default: Tcl_AppendResult(interp, "unreachable code!", NULL); return TCL_ERROR; } } /* * VertexName -- * * Returns a string, the name of the vertex identified by the given * rank in this node. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains the name of the chosen vertex. * * Side effects: * None. */ int T4Node::VertexName(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; /* * Expecting one argument. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node vertexname rank"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * See if the vertice we want exists. If not, error out. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { return TCL_ERROR; } Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) v.Name(), -1); return TCL_OK; } /* * VertexRank -- * * Return the rank of a specified vertex in this node. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains an integer representing the rank of the selected * vertex in this node. * * Side effects: * None. */ int T4Node::VertexRank(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; /* * Expecting one argument. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node vertexrank vertexspec"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * See if the vertice we want exists. If not, error out. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { return TCL_ERROR; } Tcl_SetIntObj(Tcl_GetObjResult(interp), v.Rank()); return TCL_OK; } /* * RenameVertex -- * * Rename a vertex in this node to a new name. * * Results: * A standard Tcl result. * * Side effects: * May rename a vertex in the persistent storage. */ int T4Node::RenameVertex(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { char *fn; char *vn; int i; T4VertexNameKinds vnk; /* * Expecting two arguments. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node renamevertex vertex newname"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Parse the name of the vertex to rename. */ vn = Tcl_GetString(objv[0]); if (T4Graph_ParseVertexName(interp, vn, &fn, &i, &vnk) == TCL_ERROR) { return TCL_ERROR; } /* * If the vertex is specified by index, convert it to a rank. */ if (vnk == T4VNK_INDEX) { i = n.VertexRank(fn, i); if (i == E4_VERTEXNOTFOUND) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can not rename vertex ", Tcl_GetString(objv[0]), " in node ", GetName(), NULL); return TCL_ERROR; } } /* * No longer need "fn", so we can reset the interpreter result here. */ Tcl_ResetResult(interp); /* * Attempt to rename the specified vertex. */ if (!n.RenameVertex(i, Tcl_GetString(objv[1]))) { if (vnk == T4VNK_INDEX) { Tcl_AppendResult(interp, "can not rename vertex ", Tcl_GetString(objv[0]), " in node ", GetName(), NULL); } else { Tcl_AppendResult(interp, "can not rename vertex ranked ", Tcl_GetString(objv[0]), " in node ", GetName(), NULL); } return TCL_ERROR; } return TCL_OK; } /* * Exists -- * * Return a boolean value indicating whether the selected vertex * exists. The vertex is specified either as a simple name or as * an indexed name. * * Results: * A standard Tcl result. * * Side effects: * None. */ int T4Node::Exists(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; /* * Expecting one argument. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node exists vertexspec"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * If the vertex exists, set the interp result to 1, else to 0. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { Tcl_ResetResult(interp); Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); } else { Tcl_ResetResult(interp); Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } return TCL_OK; } /* * Parent -- * * Retrieve the node that is a specified (numbered) parent of this node. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains a string, the name by which the selected parent node is * known in Tcl. * * Side effects: * A node may be exported to Tcl. */ int T4Node::Parent(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Node p; e4_NodeUniqueID nuid; T4Node *np; int ii = 1; Tcl_Obj *res; /* * Expecting zero or one arguments. */ if ((objc != 0) && (objc != 1)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node parent ?index?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * If an index is specified, it denotes the nth parent. In that * case retrieve the nth parent, otherwise retrieve the first one. */ if (objc == 1) { if (Tcl_GetIntFromObj(interp, objv[0], &ii) == TCL_ERROR) { return TCL_ERROR; } Tcl_ResetResult(interp); } /* * Attempt to obtain the selected parent. */ if ((!n.GetParent(ii, p)) || (!p.IsValid())) { Tcl_AppendResult(interp, "can not retrieve selected parent node ", " of node ", GetName(), NULL); return TCL_ERROR; } /* * See if we have exported this node already. If not, then * export it. */ (void) p.GetUniqueID(nuid); np = s->GetNodeById(interp, nuid); if (np == NULL) { np = new T4Node(p, s); s->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; } /* * ParentCount -- * * Returns an integer representing the number of parents that * this node has. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains an integer representing the number of parents that * this node has. * * Side effects: * None. */ int T4Node::ParentCount(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node parentcount"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Set the interpreter result to the number of parents of this node. */ Tcl_SetIntObj(Tcl_GetObjResult(interp), n.ParentCount()); return TCL_OK; } /* * OccurrenceCount -- * * Returns an integer representing either how many vertices in total * have this node as their value, or how many vertices in a specified * parent have this node as their value. In the second case, the * specified parent is passed as an argument. * * Results: * A standard Tcl result. Upon success, the interpreter result contains * an integer representing the requested occurrence count. * * Side effects: * None. */ int T4Node::OccurrenceCount(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4Node *pp; e4_Node p; /* * Expecting zero or one arguments. */ if ((objc != 0) && (objc != 1)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node occurrencecount ?parent?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * If the parent is specified, obtain it. */ if (objc == 1) { pp = (T4Node *) GO_GetInternalRep(objv[0], nodeExt); if (pp == NULL) { Tcl_AppendResult(interp, "invalid node ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } pp->ExternalizeNode(p); if (!p.IsValid()) { Tcl_AppendResult(interp, "invalid node ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } /* * Obtain the occurrence count of this node in the specified * parent. */ Tcl_SetIntObj(Tcl_GetObjResult(interp), n.OccurrenceCount(p)); return TCL_OK; } /* * Obtain the total occurrence count for this node. */ Tcl_SetIntObj(Tcl_GetObjResult(interp), n.OccurrenceCount()); return TCL_OK; } /* * ParentRank -- * * Given the name of a parent node, compute the rank of this parent * in the parents of this node. * * Results: * A standard Tcl result. Upon success, the interpreter result contains * an integer representing the rank of the given parent node in the * parents of this node. * * Side effects: * None. */ int T4Node::ParentRank(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4Node *pp; e4_Node p; /* * Expecting one argument. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node parentrank parent"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Obtain the parent node whose rank is to be computed. */ pp = (T4Node *) GO_GetInternalRep(objv[0], nodeExt); if (pp == NULL) { Tcl_AppendResult(interp, "invalid node ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } pp->ExternalizeNode(p); if (!p.IsValid()) { Tcl_AppendResult(interp, "invalid node ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } /* * Retrieve the rank for this parent node. */ Tcl_SetIntObj(Tcl_GetObjResult(interp), n.ParentRank(p)); return TCL_OK; } /* * Root -- * * Retrieves the root node of the storage containing this node. * * Results: * A standard Tcl result. Upon success, the interpreter result contains * a string, the name by which the root node of this storage is known * to Tcl. * * Side effects: * A node may be exported to Tcl. */ int T4Node::Root(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Node rn; e4_NodeUniqueID nuid; T4Node *rnp; Tcl_Obj *res; /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node root"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Retrieve the root node. */ if ((!n.GetRootNode(rn)) || (!rn.IsValid())) { Tcl_AppendResult(interp, "could not retrieve root node from node ", GetName(), NULL); return TCL_ERROR; } /* * See if we have exported this node already. If not, then export it. */ (void) rn.GetUniqueID(nuid); rnp = s->GetNodeById(interp, nuid); if (rnp == NULL) { rnp = new T4Node(rn, s); s->StoreNode(interp, rnp, nuid); } res = rnp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, rnp, interp); rnp->SetTclObject(res); } Tcl_SetObjResult(interp, res); return TCL_OK; } /* * IsRoot -- * * Returns a boolean value indicating whether this node is * the root of this storage. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains a boolean value indicating whether this node is * the root of its storage. * * Side effects: * None. */ int T4Node::IsRoot(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node isroot"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Check if this node is the root of its storage. */ if (n.IsRoot()) { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } /* * RankInParent -- * * Returns an integer representing the rank of the vertex containing * this node in its parent. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains an integer, the rank of the vertex containing this * node in its parent. * * Side effects: * None. */ int T4Node::RankInParent(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int ii = 1; /* * Expecting zero or one arguments. */ if ((objc != 0) && (objc != 1)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node rankinparent ?index?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * If the index of the parent is supplied, extract it. */ if (objc == 1) { if (Tcl_GetIntFromObj(interp, objv[0], &ii) == TCL_ERROR) { return TCL_ERROR; } Tcl_ResetResult(interp); } /* * Set the interpreter result to the rank of the vertex that contains * this node in its parent. */ Tcl_SetIntObj(Tcl_GetObjResult(interp), n.GetRankInParent(ii)); return TCL_OK; } /* * NameInParent -- * * Returns a string, the name of the vertex containing this node * in its parent. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains a string, the name of the vertex containing this node * in its parent. * * Side effects: * None. */ int T4Node::NameInParent(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int ii = 1; /* * Expecting zero arguments. */ if ((objc != 0) && (objc != 1)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node nameinparent ?index?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * If the index of the parent is specified, extract it. */ if (objc == 1) { if (Tcl_GetIntFromObj(interp, objv[0], &ii) == TCL_ERROR) { return TCL_ERROR; } Tcl_ResetResult(interp); } /* * Set the interpreter result to a string, the name of the vertex * containing this node in its parent. */ Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *) n.GetNameInParent(ii), -1); return TCL_OK; } /* * Detach -- * * Detach this node from all vertices whose value it is. * * Results: * A standard Tcl result. * * Side effects: * May delete a (sub)-graph in the persistent storage. */ int T4Node::Detach(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node detach"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * Attempt to detach the node. */ if (!n.Detach()) { Tcl_AppendResult(interp, "can not detach node ", GetName(), NULL); return TCL_ERROR; } /* * Do not leave any remnants in the interpreter result. */ Tcl_ResetResult(interp); return TCL_OK; } /* * Dispose -- * * Disposes of the Tcl command for this node. * * Results: * A standard Tcl result. This is a noop that is supported * for a while until it will be retired. * * Side effects: * None. */ int T4Node::Dispose(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { return TCL_OK; } /* * IsValid -- * * Returns a boolean indicating whether this node is valid. * * Results: * A standard Tcl result. * * Side effects: * None. */ int T4Node::IsValid(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node isvalid"); return TCL_ERROR; } /* * Set the interpreter result to a boolean object indicating whether * this node is valid. */ if (n.IsValid()) { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } /* * IsDetached -- * * Returns a boolean indicating whether this node is detached. * * Results: * A standard Tcl result. * * Side effects: * None. */ int T4Node::IsDetached(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node isdetached"); return TCL_ERROR; } /* * Set the interpreter result to a boolean object indicating whether * this node is detached. */ if (n.IsDetached()) { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } /* * Method -- * * Define a new method of this node (callable with Call). * * Results: * A standard Tcl result. Upon success, the interpreter result * contains an empty string. * * Side effects: * Adds a new vertex named by the supplied method name as the * last vertex of this node. */ int T4Node::Method(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Tcl_Obj **nobjv; int res; /* * Expecting three arguments. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node method methodname args body"); return TCL_ERROR; } /* * Compute the string value of the new vertex -- it is the list * composed of the args and body of the method. */ nobjv = (Tcl_Obj **) Tcl_Alloc(2 * sizeof(Tcl_Obj *)); nobjv[0] = objv[0]; nobjv[1] = Tcl_NewListObj(objc-1, objv+1); res = Set(interp, 2, (Tcl_Obj *CONST *) nobjv); Tcl_Free((char *) nobjv); return TCL_OK; } /* * Call -- * * Call a selected vertex as a Tcl procedure. * * Results: * A standard Tcl result. Upon success, the interpreter result * contains the result of calling the specified procedure. * * Side effects: * Whatever the called procedure does. */ int T4Node::Call(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; e4_VertexUniqueID vuid; T4CmdInfo *cmdInfo; char *storedprocname; int id, len, ret; int i; Tcl_Obj *res; Tcl_Obj *stackobjv[32]; Tcl_Obj **nobjv = stackobjv; /* * Expecting at least one argument. */ if (objc < 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node call vertex ?arg ...?"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * The vertex we want to "call" must exist. */ if (GetVertexRef(interp, Tcl_GetString(objv[0]), false, v) == TCL_ERROR) { return TCL_ERROR; } /* * Make sure that the value of this vertex is a string. If not, we can * not use it as the body of a stored procedure. */ if (v.Type() != E4_VTSTRING) { Tcl_AppendResult(interp, "vertex ", v.Name(), " cannot be used as a stored procedure", NULL); return TCL_ERROR; } /* * See if the stored command procedure is already exported to Tcl. If * not, define the stored command procedure. */ cmdInfo = s->GetVertexStoredCmdInfo(interp, v); if (cmdInfo == NULL) { /* * Ensure the namespace for stored commands from this storage * is created. */ (void) v.GetUniqueID(vuid); id = vuid.GetUniqueID(); len = 128 + s->GetNameLen(); storedprocname = Tcl_Alloc(len); sprintf(storedprocname, "namespace eval ::tgraph::%s {}", s->GetName()); (void) Tcl_Eval(interp, storedprocname); /* * Actually define the stored procedure command: */ sprintf(storedprocname, "::tgraph::%s::storedproc%d", s->GetName(), id); cmdInfo = T4Graph_DefineStoredProcedure(interp, storedprocname, s, v); if (cmdInfo == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot invoke stored procedure ", v.Name(), " in node ", GetName(), NULL); Tcl_Free(storedprocname); return TCL_ERROR; } } /* * Can't be NULL. */ res = GetTclObject(); /* * Add argument for procedure name: */ objc++; /* * Make a new objv/objc with the node object as the first argument * (so it becomes the value of this in the called procedure). */ if (objc > 31) { nobjv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * (objc + 1)); } /* * First two arguments are the method name and the * node containing this method vertex. */ nobjv[0] = objv[0]; nobjv[1] = res; /* * Copy the rest of the arguments out. */ for (i = 1; i < objc; i++) { nobjv[i+1] = objv[i]; } /* * Call the stored procedure. */ ret = (cmdInfo->objProc)(cmdInfo->objClientData, interp, objc, nobjv); /* * If the argument vector was allocated (not on stack), free it. */ if (nobjv != stackobjv) { Tcl_Free((char *) nobjv); } return ret; } /* * Foreach -- * * Visit selected components of this node, executing a Tcl command * for each visited component. * * Results: * A standard Tcl result. Upon successful completion, the interpreter * result is left empty. * * Side effects: * Whatever the Tcl command does. May export new elements of this node * to Tcl. */ static CONST84 char *selectors[] = { (char *) "vertex", (char *) "parent", (char *) NULL }; typedef enum SSelectors { SVertex = 0, SParent } SSelectors; int T4Node::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 *) "$node 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 SVertex: return VisitVertices(interp, objc, objv); case SParent: return VisitParents(interp, objc, objv); } /* * Not reached, but some compilers insist on this.. */ return TCL_ERROR; } /* * VisitVertices -- * * Helper function to visit selected vertices in this node. * * Results: * A standard Tcl result. Upon successful completion, the interpreter * result is left empty. * * Side effects: * Whatever the Tcl command executed does. May export new vertices * to Tcl, if -keep true is supplied in the arguments. */ static CONST84 char *filters[] = { (char *) "-type", (char *) "-name", (char *) NULL }; typedef enum SFilters { SType = 0, SName, } SFilters; static CONST84 char *typenames[] = { (char *) "node", (char *) "int", (char *) "double", (char *) "string", (char *) "binary", (char *) NULL }; int T4Node::VisitVertices(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_Vertex v; 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; /* * Expecting two, four, or six 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), and the command to * perform. */ if ((objc != 2) && (objc != 4) && (objc != 6)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node foreach vertex v ?-type t? ?-name n? cmd"); return TCL_ERROR; } /* * Hold onto the variable name. */ 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; } } /* * Create the iterator: */ e4_VertexVisitor vv(n, (const char *) namefilter, vt); /* * Iterate over the selected vertices. */ do { /* * Advance to next vertex. */ vv.CurrentVertexAndAdvance(v); if (!v.IsValid()) { done = true; continue; } /* * See if we already exported this vertex to Tcl. */ (void) v.GetUniqueID(vuid); vp = s->GetVertexById(interp, vuid); /* * If we did not export it, make a new T4Vertex and store it under * the ID obtained from the e4Vertex object. */ if (vp == NULL) { vp = new T4Vertex(v, s); s->StoreVertex(interp, vp, vuid); } /* * Ensure the vertex internal representation has a Tcl_Obj * * associated with it. */ res = vp->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(vertexExt, vp, interp); vp->SetTclObject(res); } (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; } } while ((!done) && (!vv.IsDone())); (void) Tcl_UnsetVar(interp, Tcl_GetString(vp1), 0); return ret; } /* * VisitParents -- * * Helper function to visit all parent nodes of this node. * * Results: * A standard Tcl result. Upon successful completion, the interpreter * result is left empty. * * Side effects: * Whatever the Tcl command executed does. May export new nodes to * Tcl. */ int T4Node::VisitParents(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int i, l; bool done; e4_Node p; e4_NodeUniqueID nuid; T4Node *np; int ret = TCL_OK, retone; Tcl_Obj *vp1, *vp2; Tcl_Obj *res; /* * Expecting exacly two arguments, the name of a variable to set to * each parent node visited, and a Tcl command to execute for * each node visited. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node foreach parent var cmd"); return TCL_ERROR; } /* * Check that this node is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "node ", GetName(), " is invalid", NULL); return TCL_ERROR; } /* * The first argument is the name of the iteration variable */ vp1 = objv[0]; vp2 = NULL; /* * Visit each parent in turn, bind it to the iteration variable and * evaluate the cmd. */ for (done = false, i = 1, l = n.ParentCount(); (!done) && (i <= l); i++) { if ((!n.GetParent(i, p)) || (!p.IsValid())) { Tcl_AppendResult(interp, "internal error: missing parent for node ", GetName(), NULL); return TCL_ERROR; } /* * See if we have exported this parent node already to Tcl. If not, * then export it. */ (void) p.GetUniqueID(nuid); np = s->GetNodeById(interp, nuid); if (np == NULL) { np = new T4Node(p, s); s->StoreNode(interp, np, nuid); } /* * Ensure the node's internal representation has an associated * Tcl_Obj *. */ res = np->GetTclObject(); if (res == NULL) { res = GO_MakeGenObject(nodeExt, np, interp); np->SetTclObject(res); } /* * Set the iteration variable: */ (void) Tcl_ObjSetVar2(interp, vp1, vp2, res, 0); /* * And finally execute the command. */ retone = Tcl_EvalObjEx(interp, objv[1], 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; } /* * Id -- * * Returns an identifier that is unique among all nodes in the * storage containing this node. * * Results: * A standard Tcl result. Upon successful completion, the interpreter * result contains the integer ID. * * Side effects: * None. */ int T4Node::Id(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { e4_NodeUniqueID nuid; /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node id"); return TCL_ERROR; } /* * Check that the node object is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "invalid node ", GetName(), NULL); return TCL_ERROR; } (void) n.GetUniqueID(nuid); Tcl_SetIntObj(Tcl_GetObjResult(interp), nuid.GetUniqueID()); return TCL_OK; } /* * UserData -- * * Sets or returns the user data associated with this node. * * Results: * A standard Tcl result. When retrieving the user data, upon * success, the interpreter result contains an integer representing * the stored user data. * * Side effects: * May modify the user data associated with this node in its * storage. */ int T4Node::UserData(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int i; /* * Expecting zero or one arguments. */ if ((objc != 0) && (objc != 1)) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node userdata ?newvalue?"); return TCL_ERROR; } /* * Check that the node object is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "invalid node ", GetName(), NULL); return TCL_ERROR; } /* * If one argument is given, it must be an integer (the new value). * Attempt to extract the new value. */ if (objc == 1) { if (Tcl_GetIntFromObj(interp, objv[0], &i) == TCL_ERROR) { return TCL_ERROR; } if (!n.SetUserData(i)) { Tcl_AppendResult(interp, "cannot set user data for node ", GetName(), NULL); return TCL_ERROR; } Tcl_ResetResult(interp); return TCL_OK; } /* * No arguments given, so we want to retrieve the value. */ if (!n.GetUserData(i)) { Tcl_AppendResult(interp, "cannot retrieve user data for node ", GetName(), NULL); return TCL_ERROR; } /* * Set the interpreter result to the retrieved value. */ Tcl_SetIntObj(Tcl_GetObjResult(interp), i); return TCL_OK; } /* * DetachFirstVertexWithNode -- * * Detach the first vertex in this node whose value is the given * child node. * * Results: * A standard Tcl result. Upon success, the interpreter result is * empty. * * Side effects: * May delete a vertex and its contents from this storage. */ int T4Node::DetachFirstVertexWithNode(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { T4Node *childp; e4_Node childn; /* * Expecting exactly one argument, the child node. */ if (objc != 1) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node detachfirstvertexwithnode child"); return TCL_ERROR; } /* * Check that the node object is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "invalid node ", GetName(), NULL); return TCL_ERROR; } /* * Attempt to retrieve the child node. */ childp = (T4Node *) GO_GetInternalRep(objv[0], nodeExt); if (childp == NULL) { Tcl_AppendResult(interp, "could not retrieve node named ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } childp->ExternalizeNode(childn); if (!childn.IsValid()) { Tcl_AppendResult(interp, "node name ", Tcl_GetString(objv[0]), " is invalid", NULL); return TCL_ERROR; } /* * Attempt to delete the first vertex containing the child node * in this node. */ if (!n.DetachFirstVertexWithNode(childn)) { Tcl_AppendResult(interp, "can not detach first vertex of ", GetName(), " that contains the node ", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } /* * Success. */ return TCL_OK; } /* * PreCache -- * * Pre-cache the vertex IDs for all vertices within this node. * * Results: * A standard Tcl result. Upon success, the interpreter result is * empty. * * Side effects: * Causes all vertex IDs for this node to be pre-cached so that * operations that access vertices will work faster. */ int T4Node::PreCache(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { /* * Expecting zero arguments. */ if (objc != 0) { Tcl_WrongNumArgs(interp, 0, NULL, (char *) "$node precache"); return TCL_ERROR; } /* * Check that the node object is valid. */ if (!n.IsValid()) { Tcl_AppendResult(interp, "invalid node ", GetName(), NULL); return TCL_ERROR; } n.PreCache(); return TCL_OK; } /* * IsValid -- * * Intended for private use by the invoker function only. */ bool T4Node::IsValid() const { return n.IsValid(); }