/* struct::tree - critcl - layer 3 definitions.
*
* -> Method functions.
* Implementations for all tree methods.
*/
#include <arc.h>
#include <graph.h>
#include <methods.h>
#include <nacommon.h>
#include <node.h>
#include <util.h>
#include <walk.h>
/* ..................................................
* Handling of all indices, numeric and 'end-x' forms. Copied straight out of
* the Tcl core as this is not exported through the public API.
*/
static int TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr,
int endValue, int* indexPtr);
/* .................................................. */
#define FAIL(x) if (!(x)) { return TCL_ERROR; }
/* .................................................. */
/*
*---------------------------------------------------------------------------
*
* gm_GASSIGN --
*
* Copies the argument graph over into this graph object. Uses direct
* access to internal data structures for matching graph objects, and
* goes through a serialize/deserialize combination otherwise.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* Only internal, memory allocation changes ...
*
*---------------------------------------------------------------------------
*/
int
gm_GASSIGN (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph = source
* [0] [1] [2]
*/
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "source");
return TCL_ERROR;
}
return g_ms_assign (interp, g, objv [2]);
}
/*
*---------------------------------------------------------------------------
*
* gm_GSET --
*
* Copies this graph over into the argument graph. Uses direct access to
* internal data structures for matching graph objects, and goes through a
* serialize/deserialize combination otherwise.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* Only internal, memory allocation changes ...
*
*---------------------------------------------------------------------------
*/
int
gm_GSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph --> dest(ination)
* [0] [1] [2]
*/
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "dest");
return TCL_ERROR;
}
return g_ms_set (interp, objv[0], g, objv [2]);
}
/*
*---------------------------------------------------------------------------
*
* gm_APPEND --
*
* Appends a value to an attribute of the graph.
* May create the attribute.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph append key value
* [0] [1] [2] [3]
*/
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "key value");
return TCL_ERROR;
}
g_attr_extend (&g->attr);
g_attr_append (g->attr, interp, objv[2], objv[3]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_ARCS --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_ARCS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arcs | all arcs
* graph arcs -in NODE... | arcs end in node in list
* graph arcs -out NODE... | arcs start in node in list
* graph arcs -adj NODE... | arcs start|end in node in list
* graph arcs -inner NODE... | arcs start&end in node in list
* graph arcs -embedding NODE... | arcs start^end in node in list
* graph arcs -key KEY | arcs have attribute KEY
* graph arcs -value VALUE | arcs have KEY and VALUE
* graph arcs -filter CMDPREFIX | arcs for which CMD returns True.
* [0] [1] [2] [3]
*
* -value requires -key.
* -in/-out/-adj/-inner/-embedding are exclusive.
* Each option can be used at most once.
*/
return gc_filter (0, interp, objc, objv, &g->arcs,
(GN_GET_GC*) ga_get_arc, g);
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_APPEND --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc append ARC KEY VALUE
* [0] [1] [2] [3] [4] [5]
*/
GA* a;
if (objc != 6) {
Tcl_WrongNumArgs (interp, 3, objv, "arc key value");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
g_attr_extend (&a->base.attr);
g_attr_append (a->base.attr, interp, objv[4], objv[5]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_ATTR --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_ATTR (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc attr KEY
* graph arc attr KEY -arcs LIST
* graph arc attr KEY -glob PATTERN
* graph arc attr KEY -regexp PATTERN
* [0] [1] [2] [3] [4] [5]
*/
static const char* types [] = {
"-arcs", "-glob","-regexp", NULL
};
int modes [] = {
A_LIST, A_GLOB, A_REGEXP
};
int mode;
Tcl_Obj* detail;
if ((objc != 4) && (objc != 6)) {
Tcl_WrongNumArgs (interp, 3, objv,
"key ?-arcs list|-glob pattern|-regexp pattern?");
return TCL_ERROR;
}
if (objc != 6) {
detail = NULL;
mode = A_NONE;
} else {
detail = objv [5];
if (Tcl_GetIndexFromObj (interp, objv [4], types, "type",
0, &mode) != TCL_OK) {
return TCL_ERROR;
}
mode = modes [mode];
}
return gc_attr (&g->arcs, mode, detail, interp, objv[3],
(GN_GET_GC*) ga_get_arc, g);
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_DELETE --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_DELETE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc delete ARC ARC...
* [0] [1] [2] [3] [4+]
*/
GA* a;
int i;
if (objc < 4) {
Tcl_WrongNumArgs (interp, 3, objv, "arc arc...");
return TCL_ERROR;
}
for (i=3; i<objc; i++) {
a = ga_get_arc (g, objv[i], interp, objv[0]);
FAIL (a);
}
for (i=3; i<objc; i++) {
a = ga_get_arc (g, objv[i], interp, objv[0]);
ga_delete (a);
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_EXISTS --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_EXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc exists NAME
* [0] [1] [2] [3]
*/
GA* a;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 3, objv, "arc");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], NULL, NULL);
Tcl_SetObjResult (interp, Tcl_NewIntObj (a != NULL));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_FLIP --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_FLIP (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc flip ARC
* [0] [1] [2] [3]
*/
GA* a;
GN* src;
GN* dst;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 3, objv, "arc");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
src = a->start->n;
dst = a->end->n;
if (src != dst) {
ga_mv_src (a, dst);
ga_mv_dst (a, src);
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_GET --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc get ARC KEY
* [0] [1] [2] [3] [4]
*/
GA* a;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "arc key");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
return g_attr_get (a->base.attr, interp, objv[4],
objv [3], "\" for arc \"");
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_GETALL --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc getall ARC ?PATTERN?
* [0] [1] [2] [3] [4]
*/
GA* a;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs (interp, 3, objv, "arc ?pattern?");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
g_attr_getall (a->base.attr, interp, objc-4, objv+4);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_INSERT --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_INSERT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc insert SOURCE TARGET ?ARC?
* [0] [1] [2] [3] [4] [5]
*/
GN* src;
GN* dst;
GA* a;
const char* name;
if ((objc != 5) && (objc != 6)) {
Tcl_WrongNumArgs (interp, 3, objv, "source target ?arc?");
return TCL_ERROR;
}
Tcl_AppendResult (interp, "source ", NULL);
src = gn_get_node (g, objv [3], interp, objv[0]);
FAIL (src);
Tcl_ResetResult (interp);
Tcl_AppendResult (interp, "target ", NULL);
dst = gn_get_node (g, objv [4], interp, objv[0]);
FAIL (dst);
Tcl_ResetResult (interp);
if (objc == 6) {
/* Explicit arc name, must not exist */
if (ga_get_arc (g, objv [5], NULL, NULL)) {
ga_err_duplicate (interp, objv[5], objv[0]);
return TCL_ERROR;
}
/* No matching arc found */
/* Create arc with specified name, */
/* then insert it */
name = Tcl_GetString (objv [5]);
} else {
/* Create a single new node with a generated name, */
/* then insert it. */
name = g_newarcname (g);
}
a = ga_new (g, name, src, dst);
Tcl_SetObjResult (interp, Tcl_NewListObj (1, &a->base.name));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_KEYEXISTS --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc keyexists ARC KEY
* [0] [1] [2] [3] [4]
*/
GA* a;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "arc key");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
g_attr_kexists (a->base.attr, interp, objv[4]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_KEYS --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc keys ARC ?PATTERN?
* [0] [1] [2] [3] [4]
*/
GA* a;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs (interp, 3, objv, "arc ?pattern?");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
g_attr_keys (a->base.attr, interp, objc-4, objv+4);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_LAPPEND --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc lappend ARC KEY VALUE
* [0] [1] [2] [3] [4] [5]
*/
GA* a;
if (objc != 6) {
Tcl_WrongNumArgs (interp, 3, objv, "arc key value");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
g_attr_extend (&a->base.attr);
g_attr_lappend (a->base.attr, interp, objv[4], objv[5]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_MOVE --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_MOVE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc move ARC NEWSRC NEWDST
* [0] [1] [2] [3] [4] [5]
*/
GA* a;
GN* nsrc;
GN* ndst;
if (objc != 6) {
Tcl_WrongNumArgs (interp, 3, objv, "arc newsource newtarget");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
nsrc = gn_get_node (g, objv [4], interp, objv [0]);
FAIL (nsrc);
ndst = gn_get_node (g, objv [5], interp, objv [0]);
FAIL (ndst);
ga_mv_src (a, nsrc);
ga_mv_dst (a, ndst);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_MOVE_SRC --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_MOVE_SRC (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc move ARC NEWSRC
* [0] [1] [2] [3] [4]
*/
GA* a;
GN* nsrc;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "arc newsource");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
nsrc = gn_get_node (g, objv [4], interp, objv [0]);
FAIL (nsrc);
ga_mv_src (a, nsrc);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_MOVE_TARG --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_MOVE_TARG (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc move ARC NEWDST
* [0] [1] [2] [3] [4]
*/
GA* a;
GN* ndst;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "arc newtarget");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
ndst = gn_get_node (g, objv [4], interp, objv [0]);
FAIL (ndst);
ga_mv_dst (a, ndst);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_RENAME --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_RENAME (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc rename ARC NEW
* [0] [1] [2] [3] [4]
*/
GC* c;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "arc newname");
return TCL_ERROR;
}
c = (GC*) ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (c);
if (ga_get_arc (g, objv [4], NULL, NULL)) {
ga_err_duplicate (interp, objv[4], objv[0]);
return TCL_ERROR;
}
gc_rename (c, &g->arcs, objv[4], interp);
ga_shimmer_self ((GA*) c);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_SET --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc set ARC KEY ?VALUE?
* [0] [1] [2] [3] [4] [5]
*/
GA* a;
if ((objc != 5) && (objc != 6)) {
Tcl_WrongNumArgs (interp, 3, objv, "arc key ?value?");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
if (objc == 5) {
return g_attr_get (a->base.attr, interp, objv[4],
objv [3], "\" for arc \"");
} else {
g_attr_extend (&a->base.attr);
g_attr_set (a->base.attr, interp, objv[4], objv[5]);
return TCL_OK;
}
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_SOURCE --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_SOURCE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc source ARC
* [0] [1] [2] [3]
*/
GA* a;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 3, objv, "arc");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
Tcl_SetObjResult (interp, a->start->n->base.name);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_TARGET --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_TARGET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc target ARC
* [0] [1] [2] [3]
*/
GA* a;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 3, objv, "arc");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
Tcl_SetObjResult (interp, a->end->n->base.name);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_arc_UNSET --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_arc_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc unset ARC KEY
* [0] [1] [2] [3] [4]
*/
GA* a;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "arc key");
return TCL_ERROR;
}
a = ga_get_arc (g, objv [3], interp, objv [0]);
FAIL (a);
g_attr_unset (a->base.attr, objv [4]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_DESERIALIZE --
*
* Parses a Tcl value containing a serialized graph and copies it over
* the existing graph.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_DESERIALIZE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph deserialize serial
* [0] [1] [2]
*
* SV = { NODE ATTR/node ARCS ... ATTR/graph }
*
* using:
* ATTR/x = { key value ... }
* ARCS = { { NAME targetNODEref ATTR/arc } ... }
*/
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "serial");
return TCL_ERROR;
}
return g_deserialize (g, interp, objv [2]);
}
/*
*---------------------------------------------------------------------------
*
* gm_DESTROY --
*
* Destroys the whole graph object.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* Releases memory.
*
*---------------------------------------------------------------------------
*/
int
gm_DESTROY (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph destroy
* [0] [1]
*/
if (objc != 2) {
Tcl_WrongNumArgs (interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_DeleteCommandFromToken(interp, g->cmd);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_GET --
*
* Returns the value of the named attribute in the graph.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph get key
* [0] [1] [2]
*/
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "key");
return TCL_ERROR;
}
return g_attr_get (g->attr, interp, objv[2],
objv [0], "\" for graph \"");
}
/*
*---------------------------------------------------------------------------
*
* gm_GETALL --
*
* Returns a dictionary containing all attributes and their values of
* the graph.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph getall ?pattern?
* [0] [1] [2]
*/
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs (interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
g_attr_getall (g->attr, interp, objc-2, objv+2);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_KEYEXISTS --
*
* Returns a boolean value signaling whether the graph has the
* named attribute or not. True implies that the attribute exists.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph keyexists key
* [0] [1] [2]
*/
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "key");
return TCL_ERROR;
}
g_attr_kexists (g->attr, interp, objv[2]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_KEYS --
*
* Returns a list containing all attribute names matching the pattern
* for the attributes of the graph.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph keys ?pattern?
* [0] [1] [2]
*/
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs (interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
g_attr_keys (g->attr, interp, objc-2, objv+2);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_LAPPEND --
*
* Appends a value as list element to an attribute of the graph.
* May create the attribute.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph lappend key value
* [0] [1] [2] [3]
*/
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "key value");
return TCL_ERROR;
}
g_attr_extend (&g->attr);
g_attr_lappend (g->attr, interp, objv[2], objv[3]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_NODES --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_NODES (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* nwa = nodes with arc, st = starting, en = ending
*
* Syntax: graph nodes | all nodes
* graph nodes -in NODE... | nwa en in node in list
* graph nodes -out NODE... | nwa st in node in list
* graph nodes -adj NODE... | nwa st|en in node in list
* graph nodes -inner NODE... | nwa st&en in node in list
* graph nodes -embedding NODE... | nwa st^en in node in list
* graph nodes -key KEY | nodes have attribute KEY
* graph nodes -value VALUE | nodes have KEY and VALUE
* graph nodes -filter CMDPREFIX | nodes for which CMD returns True.
* [0] [1] [2] [3]
*
* -in/-out/-adj/-inner/-embedding are exclusive.
* -value requires -key.
* Each option can be used at most once.
*/
return gc_filter (1, interp, objc, objv, &g->nodes,
(GN_GET_GC*) gn_get_node, g);
}
/*
*---------------------------------------------------------------------------
*
* gm_node_APPEND --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node append NODE KEY VALUE
* [0] [1] [2] [3] [4] [5]
*/
GN* n;
if (objc != 6) {
Tcl_WrongNumArgs (interp, 3, objv, "node key value");
return TCL_ERROR;
}
n = gn_get_node (g, objv [3], interp, objv [0]);
FAIL (n);
g_attr_extend (&n->base.attr);
g_attr_append (n->base.attr, interp, objv[4], objv[5]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_ATTR --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_ATTR (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node attr KEY
* graph node attr KEY -nodes LIST
* graph node attr KEY -glob PATTERN
* graph node attr KEY -regexp PATTERN
* [0] [1] [2] [3] [4] [5]
*/
static const char* types [] = {
"-glob", "-nodes", "-regexp", NULL
};
int modes [] = {
A_GLOB, A_LIST, A_REGEXP
};
int mode;
Tcl_Obj* detail;
if ((objc != 4) && (objc != 6)) {
Tcl_WrongNumArgs (interp, 3, objv,
"key ?-nodes list|-glob pattern|-regexp pattern?");
return TCL_ERROR;
}
if (objc != 6) {
detail = NULL;
mode = A_NONE;
} else {
detail = objv [5];
if (Tcl_GetIndexFromObj (interp, objv [4], types, "type",
0, &mode) != TCL_OK) {
return TCL_ERROR;
}
mode = modes [mode];
}
return gc_attr (&g->nodes, mode, detail, interp, objv[3],
(GN_GET_GC*) gn_get_node, g);
}
/*
*---------------------------------------------------------------------------
*
* gm_node_DEGREE --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_DEGREE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node degree -in|-out NODE
* [0] [1] [2] [3] [4]
*
* graph node degree NODE
* [0] [1] [2] [3]
*/
GN* n;
int dmode;
int degree;
Tcl_Obj* node;
static const char* dmode_s [] = {
"-in", "-out", NULL
};
enum dmode_e {
D_IN, D_OUT, D_ALL
};
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs (interp, 3, objv, "?-in|-out? node");
return TCL_ERROR;
}
if (objc == 5) {
if (Tcl_GetIndexFromObj (interp, objv [3], dmode_s,
"option", 0, &dmode) != TCL_OK) {
return TCL_ERROR;
}
node = objv [4];
} else {
dmode = D_ALL;
node = objv [3];
}
n = gn_get_node (g, node, interp, objv [0]);
FAIL (n);
switch (dmode) {
case D_IN: degree = n->in.n; break;
case D_OUT: degree = n->out.n; break;
case D_ALL: degree = n->in.n + n->out.n; break;
}
Tcl_SetObjResult (interp, Tcl_NewIntObj (degree));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_DELETE --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_DELETE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node delete NODE NODE...
* [0] [1] [2] [3] [4+]
*/
int i;
GN* n;
if (objc < 4) {
Tcl_WrongNumArgs (interp, 3, objv, "node node...");
return TCL_ERROR;
}
for (i=3; i< objc; i++) {
n = gn_get_node (g, objv [i], interp, objv [0]);
FAIL (n);
}
for (i=3; i< objc; i++) {
n = gn_get_node (g, objv [i], interp, objv [0]);
gn_delete (n);
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_EXISTS --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_EXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node exists NAME
* [0] [1] [2] [3]
*/
GN* n;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 3, objv, "node");
return TCL_ERROR;
}
n = gn_get_node (g, objv [3], NULL, NULL);
Tcl_SetObjResult (interp, Tcl_NewIntObj (n != NULL));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_GET --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node get ARC KEY
* [0] [1] [2] [3] [4]
*/
GN* n;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "node key");
return TCL_ERROR;
}
n = gn_get_node (g, objv [3], interp, objv [0]);
FAIL (n);
return g_attr_get (n->base.attr, interp, objv[4],
objv [3], "\" for node \"");
}
/*
*---------------------------------------------------------------------------
*
* gm_node_GETALL --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph arc getall ARC ?PATTERN?
* [0] [1] [2] [3] [4]
*/
GN* n;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs (interp, 3, objv, "node ?pattern?");
return TCL_ERROR;
}
n = gn_get_node (g, objv [3], interp, objv [0]);
FAIL (n);
g_attr_getall (n->base.attr, interp, objc-4, objv+4);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_INSERT --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_INSERT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node insert ?NODE...?
* [0] [1] [2] [3]
*/
GN* n;
if (objc < 3) {
Tcl_WrongNumArgs (interp, 3, objv, "?node...?");
return TCL_ERROR;
}
if (objc >= 4) {
int lc, i;
Tcl_Obj** lv;
/* Explicit node names, must not exist */
for (i=3; i<objc; i++) {
if (gn_get_node (g, objv [i], NULL, NULL)) {
gn_err_duplicate (interp, objv[i], objv[0]);
return TCL_ERROR;
}
}
/* No matching nodes found. Create nodes with specified name, then
* insert them
*/
lc = objc-3;
lv = NALLOC (lc, Tcl_Obj*);
for (i=3; i<objc; i++) {
n = gn_new (g, Tcl_GetString (objv [i]));
lv [i-3] = n->base.name;
}
Tcl_SetObjResult (interp, Tcl_NewListObj (lc, lv));
ckfree ((char*) lv);
} else {
/* Create a single new node with a generated name, then insert it. */
n = gn_new (g, g_newnodename (g));
Tcl_SetObjResult (interp, Tcl_NewListObj (1, &n->base.name));
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_KEYEXISTS --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node keyexists ARC KEY
* [0] [1] [2] [3] [4]
*/
GN* n;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "node key");
return TCL_ERROR;
}
n = gn_get_node (g, objv [3], interp, objv [0]);
FAIL (n);
g_attr_kexists (n->base.attr, interp, objv[4]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_KEYS --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node keys NODE ?PATTERN?
* [0] [1] [2] [3] [4]
*/
GN* n;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs (interp, 3, objv, "node ?pattern?");
return TCL_ERROR;
}
n = gn_get_node (g, objv [3], interp, objv [0]);
FAIL (n);
g_attr_keys (n->base.attr, interp, objc-4, objv+4);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_LAPPEND --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node lappend NODE KEY VALUE
* [0] [1] [2] [3] [4] [5]
*/
GN* n;
if (objc != 6) {
Tcl_WrongNumArgs (interp, 3, objv, "node key value");
return TCL_ERROR;
}
n = gn_get_node (g, objv [3], interp, objv [0]);
FAIL (n);
g_attr_extend (&n->base.attr);
g_attr_lappend (n->base.attr, interp, objv[4], objv[5]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_OPPOSITE --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_OPPOSITE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node opposite NODE ARC
* [0] [1] [2] [3] [4]
*/
GN* n;
GA* a;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "node arc");
return TCL_ERROR;
}
n = gn_get_node (g, objv [3], interp, objv [0]);
FAIL (n);
a = ga_get_arc (g, objv [4], interp, objv [0]);
FAIL (a);
if (a->start->n == n) {
Tcl_SetObjResult (interp, a->end->n->base.name);
} else if (a->end->n == n) {
Tcl_SetObjResult (interp, a->start->n->base.name);
} else {
Tcl_Obj* err = Tcl_NewObj ();
Tcl_AppendToObj (err, "node \"", -1);
Tcl_AppendObjToObj (err, n->base.name);
Tcl_AppendToObj (err, "\" and arc \"", -1);
Tcl_AppendObjToObj (err, a->base.name);
Tcl_AppendToObj (err, "\" are not connected in graph \"", -1);
Tcl_AppendObjToObj (err, objv [0]);
Tcl_AppendToObj (err, "\"", -1);
Tcl_SetObjResult (interp, err);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_RENAME --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_RENAME (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node rename NODE NEW
* [0] [1] [2] [3] [4]
*/
GC* c;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "node newname");
return TCL_ERROR;
}
c = (GC*) gn_get_node (g, objv [3], interp, objv [0]);
FAIL (c);
if (gn_get_node (g, objv [4], NULL, NULL)) {
gn_err_duplicate (interp, objv[4], objv[0]);
return TCL_ERROR;
}
gc_rename (c, &g->nodes, objv[4], interp);
gn_shimmer_self ((GN*) c);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_node_SET --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node set NODE KEY ?VALUE?
* [0] [1] [2] [3] [4] [5]
*/
GC* c;
if ((objc != 5) && (objc != 6)) {
Tcl_WrongNumArgs (interp, 3, objv, "node key ?value?");
return TCL_ERROR;
}
c = (GC*) gn_get_node (g, objv [3], interp, objv [0]);
FAIL (c);
if (objc == 5) {
return g_attr_get (c->attr, interp, objv[4],
objv [3], "\" for node \"");
} else {
g_attr_extend (&c->attr);
g_attr_set (c->attr, interp, objv[4], objv[5]);
return TCL_OK;
}
}
/*
*---------------------------------------------------------------------------
*
* gm_node_UNSET --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_node_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph node unset NODE KEY
* [0] [1] [2] [3] [4]
*/
GC* c;
if (objc != 5) {
Tcl_WrongNumArgs (interp, 3, objv, "node key");
return TCL_ERROR;
}
c = (GC*) gn_get_node (g, objv [3], interp, objv [0]);
FAIL (c);
g_attr_unset (c->attr, objv [4]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_SERIALIZE --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_SERIALIZE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph serialize NODE...
* [0] [1] [2]
*
* SV = { NODE ATTR/node ARCS ... ATTR/graph }
*
* using:
* ATTR/x = { key value ... }
* ARCS = { { NAME targetNODEref ATTR/arc } ... }
*/
Tcl_Obj* sv = g_ms_serialize (interp, objv[0], g, objc-2, objv+2);
if (!sv) {
return TCL_ERROR;
}
Tcl_SetObjResult (interp, sv);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_SET --
*
* Adds an attribute and its value to the graph. May replace an
* existing value.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph set key ?value?
* [0] [1] [2] [3]
*/
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs (interp, 2, objv, "key ?value?");
return TCL_ERROR;
}
if (objc == 3) {
return g_attr_get (g->attr, interp, objv[2],
objv [0], "\" for graph \"");
} else {
g_attr_extend (&g->attr);
g_attr_set (g->attr, interp, objv[2], objv[3]);
return TCL_OK;
}
}
/*
*---------------------------------------------------------------------------
*
* gm_SWAP --
*
* Swap the names of two nodes.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
gm_SWAP (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph swap a b
* [0] [1] [2] [3]
*/
GN* na;
GN* nb;
const char* key;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "node1 node2");
return TCL_ERROR;
}
na = gn_get_node (g, objv [2], interp, objv [0]);
FAIL (na);
nb = gn_get_node (g, objv [3], interp, objv [0]);
FAIL (nb);
if (na == nb) {
Tcl_Obj* err = Tcl_NewObj ();
Tcl_AppendToObj (err, "cannot swap node \"", -1);
Tcl_AppendObjToObj (err, objv [2]);
Tcl_AppendToObj (err, "\" with itself", -1);
Tcl_SetObjResult (interp, err);
return TCL_ERROR;
}
{
#define SWAP(a,b,t) t = a; a = b ; b = t
#define SWAPS(x,t) SWAP(na->x,nb->x,t)
/* The two nodes flip all structural information around to trade places */
/* It might actually be easier to flip the non-structural data */
/* name, he, attr, data in the node map */
Tcl_Obj* to;
Tcl_HashTable* ta;
Tcl_HashEntry* th;
SWAPS (base.name, to);
SWAPS (base.attr, ta);
SWAPS (base.he, th);
Tcl_SetHashValue (na->base.he, (ClientData) na);
Tcl_SetHashValue (nb->base.he, (ClientData) nb);
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_UNSET --
*
* Removes an attribute and its value from the graph.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release memory.
*
*---------------------------------------------------------------------------
*/
int
gm_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph unset key
* [0] [1] [2]
*/
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "key");
return TCL_ERROR;
}
g_attr_unset (g->attr, objv [2]);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* gm_WALK --
*
*
*
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
gm_WALK (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
/* Syntax: graph walk NODE ?-type TYPE? ?-order ORDER? ?-dir DIR? -command CMD
* [0] [1] [2] [3] [4] [5] [6] [7] [8] [9] [10]
*
* TYPE bfs|dfs
* ORDER pre|post|both
* DIR backward|forward
*
* bfs => !post && !both
*/
int cc, type, order, dir;
Tcl_Obj** cv;
GN* n;
if (objc < 5) {
Tcl_WrongNumArgs (interp, 2, objv, W_USAGE);
return TCL_ERROR;
}
n = gn_get_node (g, objv [2], interp, objv [0]);
FAIL(n);
if (g_walkoptions (interp, objc, objv,
&type, &order, &dir,
&cc, &cv) != TCL_OK) {
return TCL_ERROR;
}
return g_walk (interp, objv[0], n, type, order, dir, cc, cv);
}
/* .................................................. */
/* .................................................. */
/*
* Handling of all indices, numeric and 'end-x' forms. Copied straight out of
* the Tcl core as this is not exported through the public API.
*
* I.e. a full copy of TclGetIntForIndex, its Tcl_ObjType, and of several
* supporting functions and macros internal to the core. :(
*
* To avoid clashing with the object type in the core the object type here has
* been given a different name.
*/
#define UCHAR(c) ((unsigned char) (c))
static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* objPtr));
static int TclCheckBadOctal (Tcl_Interp *interp, const char *value);
static int TclFormatInt (char *buffer, long n);
Tcl_ObjType EndOffsetTypeGraph = {
"tcllib/struct::graph/end-offset", /* name */
(Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */
UpdateStringOfEndOffset, /* updateStringProc */
SetEndOffsetFromAny
};
static int
TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, int endValue, int* indexPtr)
{
if (Tcl_GetIntFromObj (NULL, objPtr, indexPtr) == TCL_OK) {
return TCL_OK;
}
if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
/*
* If the object is already an offset from the end of the
* list, or can be converted to one, use it.
*/
*indexPtr = endValue + objPtr->internalRep.longValue;
} else {
/*
* Report a parse error.
*/
if (interp != NULL) {
char *bytes = Tcl_GetString(objPtr);
/*
* The result might not be empty; this resets it which
* should be both a cheap operation, and of little problem
* because this is an error-generation path anyway.
*/
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be integer or end?-integer?",
(char *) NULL);
if (!strncmp(bytes, "end-", 3)) {
bytes += 3;
}
TclCheckBadOctal(interp, bytes);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfEndOffset --
*
* Update the string rep of a Tcl object holding an "end-offset"
* expression.
*
* Results:
* None.
*
* Side effects:
* Stores a valid string in the object's string rep.
*
* This procedure does NOT free any earlier string rep. If it is
* called on an object that already has a valid string rep, it will
* leak memory.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfEndOffset(objPtr)
register Tcl_Obj* objPtr;
{
char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
register int len;
strcpy(buffer, "end");
len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
}
objPtr->bytes = ckalloc((unsigned) (len+1));
strcpy(objPtr->bytes, buffer);
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* SetEndOffsetFromAny --
*
* Look for a string of the form "end-offset" and convert it
* to an internal representation holding the offset.
*
* Results:
* Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
*
* Side effects:
* If interp is not NULL, stores an error message in the
* interpreter result.
*
*----------------------------------------------------------------------
*/
static int
SetEndOffsetFromAny(interp, objPtr)
Tcl_Interp* interp; /* Tcl interpreter or NULL */
Tcl_Obj* objPtr; /* Pointer to the object to parse */
{
int offset; /* Offset in the "end-offset" expression */
Tcl_ObjType* oldTypePtr = objPtr->typePtr;
/* Old internal rep type of the object */
register char* bytes; /* String rep of the object */
int length; /* Length of the object's string rep */
/* If it's already the right type, we're fine. */
if (objPtr->typePtr == &EndOffsetTypeGraph) {
return TCL_OK;
}
/* Check for a string rep of the right form. */
bytes = Tcl_GetStringFromObj(objPtr, &length);
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be end?-integer?",
(char*) NULL);
}
return TCL_ERROR;
}
/* Convert the string rep */
if (length <= 3) {
offset = 0;
} else if ((length > 4) && (bytes[3] == '-')) {
/*
* This is our limited string expression evaluator. Pass everything
* after "end-" to Tcl_GetInt, then reverse for offset.
*/
if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
return TCL_ERROR;
}
offset = -offset;
} else {
/*
* Conversion failed. Report the error.
*/
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be integer or end?-integer?",
(char *) NULL);
}
return TCL_ERROR;
}
/*
* The conversion succeeded. Free the old internal rep and set
* the new one.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.longValue = offset;
objPtr->typePtr = &EndOffsetTypeGraph;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCheckBadOctal --
*
* This procedure checks for a bad octal value and appends a
* meaningful error to the interp's result.
*
* Results:
* 1 if the argument was a bad octal, else 0.
*
* Side effects:
* The interpreter's result is modified.
*
*----------------------------------------------------------------------
*/
static int
TclCheckBadOctal(interp, value)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
const char *value; /* String to check. */
{
register const char *p = value;
/*
* A frequent mistake is invalid octal values due to an unwanted
* leading zero. Try to generate a meaningful error message.
*/
while (isspace(UCHAR(*p))) { /* INTL: ISO space. */
p++;
}
if (*p == '+' || *p == '-') {
p++;
}
if (*p == '0') {
while (isdigit(UCHAR(*p))) { /* INTL: digit. */
p++;
}
while (isspace(UCHAR(*p))) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
/* Reached end of string */
if (interp != NULL) {
/*
* Don't reset the result here because we want this result
* to be added to an existing error message as extra info.
*/
Tcl_AppendResult(interp, " (looks like invalid octal number)",
(char *) NULL);
}
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclFormatInt --
*
* This procedure formats an integer into a sequence of decimal digit
* characters in a buffer. If the integer is negative, a minus sign is
* inserted at the start of the buffer. A null character is inserted at
* the end of the formatted characters. It is the caller's
* responsibility to ensure that enough storage is available. This
* procedure has the effect of sprintf(buffer, "%d", n) but is faster.
*
* Results:
* An integer representing the number of characters formatted, not
* including the terminating \0.
*
* Side effects:
* The formatted characters are written into the storage pointer to
* by the "buffer" argument.
*
*----------------------------------------------------------------------
*/
static int
TclFormatInt(buffer, n)
char *buffer; /* Points to the storage into which the
* formatted characters are written. */
long n; /* The integer to format. */
{
long intVal;
int i;
int numFormatted, j;
char *digits = "0123456789";
/*
* Check first whether "n" is zero.
*/
if (n == 0) {
buffer[0] = '0';
buffer[1] = 0;
return 1;
}
/*
* Check whether "n" is the maximum negative value. This is
* -2^(m-1) for an m-bit word, and has no positive equivalent;
* negating it produces the same value.
*/
if (n == -n) {
sprintf(buffer, "%ld", n);
return strlen(buffer);
}
/*
* Generate the characters of the result backwards in the buffer.
*/
intVal = (n < 0? -n : n);
i = 0;
buffer[0] = '\0';
do {
i++;
buffer[i] = digits[intVal % 10];
intVal = intVal/10;
} while (intVal > 0);
if (n < 0) {
i++;
buffer[i] = '-';
}
numFormatted = i;
/*
* Now reverse the characters.
*/
for (j = 0; j < i; j++, i--) {
char tmp = buffer[i];
buffer[i] = buffer[j];
buffer[j] = tmp;
}
return numFormatted;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
syntax highlighted by Code2HTML, v. 0.9.1