Attachment "483125.diff" to
ticket [483125ffff]
added by
andreas_kupries
2001-11-20 06:29:54.
? modules/fileinput
? modules/ftp/LOG
? modules/ftp/bar
? modules/ftp/foo
? modules/ftp/test_ftpchan.tcl
? modules/ftp/example
? modules/ftpd/examples
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/ChangeLog,v
retrieving revision 1.86
diff -u -r1.86 ChangeLog
--- ChangeLog 2001/11/19 21:02:19 1.86
+++ ChangeLog 2001/11/19 23:26:48
@@ -1,7 +1,9 @@
2001-11-19 Andreas Kupries <[email protected]>
+ * struct/graph: Applied patch #483125
+
* smtpd: Example consolidation: Moved the smtpd example to
- 'examples' directory.
+ 'examples' directory.
* ftp: Implemented FR #481161.
Index: modules/struct/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/struct/ChangeLog,v
retrieving revision 1.16
diff -u -r1.16 ChangeLog
--- modules/struct/ChangeLog 2001/10/17 17:27:26 1.16
+++ modules/struct/ChangeLog 2001/11/19 23:26:49
@@ -1,3 +1,12 @@
+2001-11-19 Andreas Kupries <[email protected]>
+
+ * graph.test:
+ * graph.n:
+ * graph.tcl: Applied patch #483125 provided by Frank Pilhofer
+ <[email protected]>. The patch adds key/value information for the whole
+ graph and extends the selection methods 'arcs' and 'nodes' to
+ allow selection based on keys and their values.
+
2001-10-16 Andreas Kupries <[email protected]>
* pkgIndex.tcl:
Index: modules/struct/graph.n
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/struct/graph.n,v
retrieving revision 1.5
diff -u -r1.5 graph.n
--- modules/struct/graph.n 2001/10/17 17:27:26 1.5
+++ modules/struct/graph.n 2001/11/19 23:26:49
@@ -94,37 +94,48 @@
Remove a keyed value from the arc \fIarc\fR. If no key is
specified, the key \fBdata\fR is assumed.
.TP
-\fIgraphName\fR \fBarcs\fR ?-in|-out|-adj|-inner|-embedding \fInodelist\fR?
-
+\fIgraphName\fR \fBarcs\fR ?-key \fIkey\fR? ?-value \fIvalue\fR? ?-in|-out|-adj|-inner|-embedding \fInodelist\fR?
Return a list of arcs in the graph. If no restriction is specified a
-list containing all arcs is returned. If one of the five possible
-restrictions is specified only arcs satisfying that restriction are
-returned. All restrictions involve a list of nodes, specified after
-the key for the restriction itself.
-.IP
+list containing all arcs is returned. Restrictions can limit the list
+of returned arcs based on the nodes that are connected by the arc, on
+the keyed values associated with the arc, or both. The restrictions
+that involve connected nodes have a list of nodes as argument,
+specified after the name of the restriction itself.
+.RS
+.TP
\fB-in\fR
Return a list of all arcs whose target is one of the nodes in the
\fInodelist\fR.
-.IP
+.TP
\fB-out\fR
Return a list of all arcs whose source is one of the nodes in the
\fInodelist\fR.
-.IP
+.TP
\fB-adj\fR
Return a list of all arcs adjacent to at least one of the nodes in
the \fInodelist\fR. This is the union of the nodes returned by
\fB-in\fR and \fB-out\fR.
-.IP
+.TP
\fB-inner\fR
Return a list of all arcs adjacent to two of the nodes in the
\fInodelist\fR. This is the set of arcs in the subgraph spawned by
the specified nodes.
-.IP
+.TP
\fB-embedding\fR
Return a list of all arcs adjacent to exactly one of the nodes in the
\fInodelist\fR. This is the set of arcs connecting the subgraph
spawned by the specified nodes to the rest of the graph.
.TP
+\fB-key\fR \fIkey\fR
+Limit the list of arcs that are returned to those arcs that have an
+associated key \fIkey\fR.
+.TP
+\fB-value\fR \fIvalue\fR
+This restriction can only be used in combination with \fB-key\fR. It
+limits the list of arcs that are returned to those arcs whose
+associated key \fIkey\fR has the value \fIvalue\fR.
+.RE
+.TP
\fIgraphName\fR \fBnode degree\fR ?-in|-out? \fInode\fR
Return the number of arcs adjacent to the specified \fInode\fR. If
one of the restrictions \fB-in\fR or \fB-out\fR is given only the
@@ -163,20 +174,37 @@
Remove a keyed value from the node \fInode\fR. If no key is
specified, the key \fBdata\fR is assumed.
.TP
-\fIgraphName\fR \fBnodes\fR ?-in|-out|-adj|-inner|-embedding \fInodelist\fR?
-Return a list of nodes in the graph. If no restriction is specified a
-list containing all nodes is returned. If one of the five possible
-restrictions is specified only nodes satisfying that restriction are
-returned. All restrictions involve a list of nodes, specified after
-the key for the restriction itself.
-
+\fIgraphName\fR \fBnodes\fR ?-key \fIkey\fR? ?-value \fIvalue\fR? ?-in|-out|-adj|-inner|-embedding \fInodelist\fR?
+Return a list of nodes in the graph. Restrictions can limit the list
+of returned nodes based on neighboring nodes, or based on the keyed
+values associated with the node. The restrictions that involve
+neighboring nodes have a list of nodes as argument, specified after
+the name of the restriction itself.
+.sp
The possible restrictions are the same as for method \fBarcs\fR. The
set of nodes to return is computed as the union of all source and
target nodes for all the arcs satisfying the restriction as defined
for \fBarcs\fR.
.TP
+\fIgraphName\fR \fBget\fR ?\fI-key key\fR?
+Return the value associated with the key \fIkey\fR for the graph. If
+no key is specified, the key \fBdata\fR is assumed.
+.TP
+\fIgraphName\fR \fBset\fR ?\fI-key key\fR? ?\fIvalue\fR?
+Set or get one of the keyed values associated with a graph. If no key
+is specified, the key \fBdata\fR is assumed. Each graph has the value
+"" assigned to the key \fBdata\fR automatically. A graph may have any
+number of keyed values associated with it. If \fIvalue\fR is not
+specified, this command returns the current value assigned to the key;
+if \fIvalue\fR is specified, this command assigns that value to the
+key.
+.TP
\fIgraphName\fR \fBswap\fR \fInode1\fR \fInode2\fR
Swap the position of \fInode1\fR and \fInode2\fR in the graph.
+.TP
+\fIgraphName\fR \fBunset\fR ?\fI-key key\fR?
+Remove a keyed value from the graph. If no key is specified, the key
+\fBdata\fR is assumed.
.TP
\fIgraphName\fR \fBwalk\fR \fInode\fR ?\fI-order order\fR? ?\fI-type type\fR? ?\fI-dir direction\fR? \fI-command cmd\fR
Index: modules/struct/graph.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/struct/graph.tcl,v
retrieving revision 1.3
diff -u -r1.3 graph.tcl
--- modules/struct/graph.tcl 2001/06/22 15:29:18 1.3
+++ modules/struct/graph.tcl 2001/11/19 23:26:49
@@ -38,9 +38,12 @@
"arc" \
"arcs" \
"destroy" \
+ "get" \
"node" \
"nodes" \
+ "set" \
"swap" \
+ "unset" \
"walk" \
]
@@ -96,6 +99,10 @@
# Set up the namespace
namespace eval ::struct::graph::graph$name {
+ # Set up the map for values associated with the graph itself
+ variable graphData
+ array set graphData {data ""}
+
# Set up the map from nodes to the arcs coming to them
variable inArcs
array set inArcs {}
@@ -447,53 +454,59 @@
# arcs list of arcs
proc ::struct::graph::_arcs {name args} {
-
- if {[llength $args] == 0} {
- # No restriction, deliver all.
- upvar ::struct::graph::graph${name}::arcNodes arcNodes
- return [array names arcNodes]
- }
+ # Discriminate between conditions and nodes
- # Get mode and node list
-
- set cond [lindex $args 0]
- set args [lrange $args 1 end]
+ set haveCond 0
+ set haveKey 0
+ set haveValue 0
+ set cond "none"
+ set condNodes [list]
- # Validate that the cond is good.
- switch -glob -- $cond {
- "-in" {
- set cond "in"
- }
- "-out" {
- set cond "out"
- }
- "-adj" {
- set cond "adj"
- }
- "-inner" {
- set cond "inner"
- }
- "-embedding" {
- set cond "embedding"
- }
- default {
- error "invalid restriction \"$cond\": should be -in, -out,\
- -adj, -inner or -embedding"
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set arg [lindex $args $i]
+ switch -glob -- $arg {
+ -in -
+ -out -
+ -adj -
+ -inner -
+ -embedding {
+ set haveCond 1
+ set cond [string range $arg 1 end]
+ }
+ -key {
+ incr i
+ set key [lindex $args $i]
+ set haveKey 1
+ }
+ -value {
+ incr i
+ set value [lindex $args $i]
+ set haveValue 1
+ }
+ -* {
+ error "invalid restriction \"$arg\": should be -in, -out,\
+ -adj, -inner, -embedding, -key or -value"
+ }
+ default {
+ lappend condNodes $arg
+ }
}
}
# Validate that there are nodes to use in the restriction.
# otherwise what's the point?
- if {[llength $args] == 0} {
- set usage "$name arcs ?-in|-out|-adj|-inner|-embedding node node...?"
- error "no nodes specified: should be \"$usage\""
- }
+ if {$haveCond} {
+ if {[llength $condNodes] == 0} {
+ set usage "$name arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"
+ error "no nodes specified: should be \"$usage\""
+ }
- # Make sure that the specified nodes exist!
- foreach node $args {
- if { ![__node_exists $name $node] } {
- error "node \"$node\" does not exist in graph \"$name\""
+ # Make sure that the specified nodes exist!
+ foreach node $condNodes {
+ if { ![__node_exists $name $node] } {
+ error "node \"$node\" does not exist in graph \"$name\""
+ }
}
}
@@ -510,7 +523,7 @@
# Result is all arcs going to at least one node
# in the list of arguments.
- foreach node $args {
+ foreach node $condNodes {
foreach e $inArcs($node) {
if {[info exists coll($e)]} {continue}
lappend arcs $e
@@ -522,7 +535,7 @@
# Result is all arcs coming from at least one node
# in the list of arguments.
- foreach node $args {
+ foreach node $condNodes {
foreach e $outArcs($node) {
if {[info exists coll($e)]} {continue}
lappend arcs $e
@@ -534,7 +547,7 @@
# Result is all arcs coming from or going to at
# least one node in the list of arguments.
- foreach node $args {
+ foreach node $condNodes {
foreach e $inArcs($node) {
if {[info exists coll($e)]} {continue}
lappend arcs $e
@@ -551,11 +564,11 @@
# Result is all arcs running between nodes in the list.
array set group {}
- foreach node $args {
+ foreach node $condNodes {
set group($node) .
}
- foreach node $args {
+ foreach node $condNodes {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {![info exists group($n)]} {continue}
@@ -574,15 +587,15 @@
}
embedding {
# Result is all arcs from -adj minus the arcs from -inner.
- # IOW all arcs goint from a node in the list to a node
+ # IOW all arcs going from a node in the list to a node
# which is *not* in the list
array set group {}
- foreach node $args {
+ foreach node $condNodes {
set group($node) .
}
- foreach node $args {
+ foreach node $condNodes {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {[info exists group($n)]} {continue}
@@ -599,10 +612,37 @@
}
}
}
+ none {
+ set arcs [array names arcNodes]
+ }
default {error "Can't happen, panic"}
}
- return $arcs
+ #
+ # We have a list of arcs that match the relation to the nodes.
+ # Now filter according to -key and -value.
+ #
+
+ set filteredArcs [list]
+
+ if {$haveKey} {
+ foreach arc $arcs {
+ catch {
+ set aval [__arc_get $name $arc -key $key]
+ if {$haveValue} {
+ if {$aval == $value} {
+ lappend filteredArcs $arc
+ }
+ } else {
+ lappend filteredArcs $arc
+ }
+ }
+ }
+ } else {
+ set filteredArcs $arcs
+ }
+
+ return $filteredArcs
}
# ::struct::graph::_destroy --
@@ -656,6 +696,28 @@
return "node${nextUnusedNode}"
}
+# ::struct::graph::_get --
+#
+# Get a keyed value from the graph itself
+#
+# Arguments:
+# name name of the graph.
+# flag -key; anything else is an error
+# key key to lookup; defaults to data
+#
+# Results:
+# value value associated with the key given.
+
+proc ::struct::graph::_get {name {flag -key} {key data}} {
+ upvar ::struct::graph::graph${name}::graphData data
+
+ if { ![info exists data($key)] } {
+ error "invalid key \"$key\" for graph"
+ }
+
+ return $data($key)
+}
+
# ::struct::graph::_node --
#
# Dispatches the invocation of node methods to the proper handler
@@ -1021,53 +1083,59 @@
# nodes list of nodes
proc ::struct::graph::_nodes {name args} {
-
- if {[llength $args] == 0} {
- # No restriction, deliver all.
-
- upvar ::struct::graph::graph${name}::inArcs inArcs
- return [array names inArcs]
- }
- # Get mode and node list
+ # Discriminate between conditions and nodes
- set cond [lindex $args 0]
- set args [lrange $args 1 end]
+ set haveCond 0
+ set haveKey 0
+ set haveValue 0
+ set cond "none"
+ set condNodes [list]
- # Validate that the cond is good.
- switch -glob -- $cond {
- "-in" {
- set cond "in"
- }
- "-out" {
- set cond "out"
- }
- "-adj" {
- set cond "adj"
- }
- "-inner" {
- set cond "inner"
- }
- "-embedding" {
- set cond "embedding"
- }
- default {
- error "invalid restriction \"$cond\": should be -in, -out,\
- -adj, -inner or -embedding"
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set arg [lindex $args $i]
+ switch -glob -- $arg {
+ -in -
+ -out -
+ -adj -
+ -inner -
+ -embedding {
+ set haveCond 1
+ set cond [string range $arg 1 end]
+ }
+ -key {
+ incr i
+ set key [lindex $args $i]
+ set haveKey 1
+ }
+ -value {
+ incr i
+ set value [lindex $args $i]
+ set haveValue 1
+ }
+ -* {
+ error "invalid restriction \"$arg\": should be -in, -out,\
+ -adj, -inner, -embedding, -key or -value"
+ }
+ default {
+ lappend condNodes $arg
+ }
}
}
# Validate that there are nodes to use in the restriction.
# otherwise what's the point?
- if {[llength $args] == 0} {
- set usage "$name nodes ?-in|-out|-adj|-inner|-embedding node node...?"
- error "no nodes specified: should be \"$usage\""
- }
+ if {$haveCond} {
+ if {[llength $condNodes] == 0} {
+ set usage "$name nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"
+ error "no nodes specified: should be \"$usage\""
+ }
- # Make sure that the specified nodes exist!
- foreach node $args {
- if { ![__node_exists $name $node] } {
- error "node \"$node\" does not exist in graph \"$name\""
+ # Make sure that the specified nodes exist!
+ foreach node $condNodes {
+ if { ![__node_exists $name $node] } {
+ error "node \"$node\" does not exist in graph \"$name\""
+ }
}
}
@@ -1084,7 +1152,7 @@
# Result is all nodes with at least one arc going to
# at least one node in the list of arguments.
- foreach node $args {
+ foreach node $condNodes {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {[info exists coll($n)]} {continue}
@@ -1097,7 +1165,7 @@
# Result is all nodes with at least one arc coming from
# at least one node in the list of arguments.
- foreach node $args {
+ foreach node $condNodes {
foreach e $outArcs($node) {
set n [lindex $arcNodes($e) 1]
if {[info exists coll($n)]} {continue}
@@ -1110,7 +1178,7 @@
# Result is all nodes with at least one arc coming from
# or going to at least one node in the list of arguments.
- foreach node $args {
+ foreach node $condNodes {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {[info exists coll($n)]} {continue}
@@ -1131,11 +1199,11 @@
# arguments.
array set group {}
- foreach node $args {
+ foreach node $condNodes {
set group($node) .
}
- foreach node $args {
+ foreach node $condNodes {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {![info exists group($n)]} {continue}
@@ -1158,11 +1226,11 @@
# but not in the list itself!
array set group {}
- foreach node $args {
+ foreach node $condNodes {
set group($node) .
}
- foreach node $args {
+ foreach node $condNodes {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {[info exists group($n)]} {continue}
@@ -1179,12 +1247,87 @@
}
}
}
+ none {
+ set nodes [array names inArcs]
+ }
default {error "Can't happen, panic"}
}
+
+ #
+ # We have a list of nodes that match the relation to the nodes.
+ # Now filter according to -key and -value.
+ #
+
+ set filteredNodes [list]
+
+ if {$haveKey} {
+ foreach node $nodes {
+ catch {
+ set nval [__node_get $name $node -key $key]
+ if {$haveValue} {
+ if {$nval == $value} {
+ lappend filteredNodes $node
+ }
+ } else {
+ lappend filteredNodes $node
+ }
+ }
+ }
+ } else {
+ set filteredNodes $nodes
+ }
- return $nodes
+ return $filteredNodes
}
+# ::struct::graph::_set --
+#
+# Set or get a keyed value from the graph itself
+#
+# Arguments:
+# name name of the graph.
+# flag -key; anything else is an error
+# args ?-key key? ?value?
+#
+# Results:
+# value value associated with the key given.
+
+proc ::struct::graph::_set {name args} {
+ upvar ::struct::graph::graph${name}::graphData data
+
+ if { [llength $args] > 3 } {
+ error "wrong # args: should be \"$name set ?-key key?\
+ ?value?\""
+ }
+
+ set key "data"
+ set haveValue 0
+ if { [llength $args] > 1 } {
+ foreach {flag key} $args break
+ if { ![string match "${flag}*" "-key"] } {
+ error "invalid option \"$flag\": should be key"
+ }
+ if { [llength $args] == 3 } {
+ set haveValue 1
+ set value [lindex $args end]
+ }
+ } elseif { [llength $args] == 1 } {
+ set haveValue 1
+ set value [lindex $args end]
+ }
+
+ if { $haveValue } {
+ # Setting a value
+ return [set data($key) $value]
+ } else {
+ # Getting a value
+ if { ![info exists data($key)] } {
+ error "invalid key \"$key\" for graph"
+ }
+ return $data($key)
+ }
+}
+
# ::struct::graph::_swap --
#
# Swap two nodes in a graph.
@@ -1249,6 +1392,33 @@
array set node1Vals [array get node2Vals]
unset node2Vals
array set node2Vals $value1
+
+ return
+}
+
+# ::struct::graph::_unset --
+#
+# Remove a keyed value from the graph itself
+#
+# Arguments:
+# name name of the graph.
+# flag -key; anything else is an error
+# args additional args: ?-key key?
+#
+# Results:
+# None.
+
+proc ::struct::graph::_unset {name {flag -key} {key data}} {
+ upvar ::struct::graph::graph${name}::graphData data
+
+ if { ![string match "${flag}*" "-key"] } {
+ error "invalid option \"$flag\": should be \"$name unset\
+ ?-key key?\""
+ }
+
+ if { [info exists data($key)] } {
+ unset data($key)
+ }
return
}
Index: modules/struct/graph.test
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/struct/graph.test,v
retrieving revision 1.3
diff -u -r1.3 graph.test
--- modules/struct/graph.test 2000/06/16 20:15:32 1.3
+++ modules/struct/graph.test 2001/11/19 23:26:49
@@ -39,7 +39,7 @@
catch {mygraph foo} msg
mygraph destroy
set msg
-} "bad option \"foo\": must be arc, arcs, destroy, node, nodes, swap, or walk"
+} "bad option \"foo\": must be arc, arcs, destroy, get, node, nodes, set, swap, unset, or walk"
test graph-0.4 {graph errors} {
catch {graph set} msg
@@ -380,14 +380,14 @@
catch {mygraph arcs -foo} msg
mygraph destroy
set msg
-} {invalid restriction "-foo": should be -in, -out, -adj, -inner or -embedding}
+} {invalid restriction "-foo": should be -in, -out, -adj, -inner, -embedding, -key or -value}
test graph-10.3 {arcs} {
graph mygraph
catch {mygraph arcs -in} msg
mygraph destroy
set msg
-} {no nodes specified: should be "mygraph arcs ?-in|-out|-adj|-inner|-embedding node node...?"}
+} {no nodes specified: should be "mygraph arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"}
test graph-10.4 {arcs} {
graph mygraph
@@ -445,6 +445,32 @@
{arcA arcB arcC} \
]
+test graph-10.6 {arcs} {
+ graph mygraph
+ mygraph node insert n0
+ mygraph node insert n1
+ mygraph arc insert n0 n1 a1
+ mygraph arc insert n0 n1 a2
+ mygraph arc set a1 -key foobar 1
+ mygraph arc set a2 -key blubber 2
+ catch {mygraph arcs -key foobar} msg
+ mygraph destroy
+ set msg
+} {a1}
+
+test graph-10.7 {arcs} {
+ graph mygraph
+ mygraph node insert n0
+ mygraph node insert n1
+ mygraph arc insert n0 n1 a1
+ mygraph arc insert n0 n1 a2
+ mygraph arc set a1 -key foobar 1
+ mygraph arc set a2 -key foobar 2
+ catch {mygraph arcs -key foobar -value 1} msg
+ mygraph destroy
+ set msg
+} {a1}
+
# ---------------------------------------------------
test graph-11.1 {node degree} {
@@ -801,14 +827,14 @@
catch {mygraph nodes -foo} msg
mygraph destroy
set msg
-} {invalid restriction "-foo": should be -in, -out, -adj, -inner or -embedding}
+} {invalid restriction "-foo": should be -in, -out, -adj, -inner, -embedding, -key or -value}
test graph-19.3 {nodes} {
graph mygraph
catch {mygraph nodes -in} msg
mygraph destroy
set msg
-} {no nodes specified: should be "mygraph nodes ?-in|-out|-adj|-inner|-embedding node node...?"}
+} {no nodes specified: should be "mygraph nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"}
test graph-19.4 {nodes} {
graph mygraph
@@ -865,6 +891,28 @@
{} \
{node1 node2 node3} \
]
+
+test graph-19.6 {arcs} {
+ graph mygraph
+ mygraph node insert n0
+ mygraph node insert n1
+ mygraph node set n0 -key foobar 1
+ mygraph node set n1 -key blubber 2
+ catch {mygraph nodes -key foobar} msg
+ mygraph destroy
+ set msg
+} {n0}
+
+test graph-19.7 {arcs} {
+ graph mygraph
+ mygraph node insert n0
+ mygraph node insert n1
+ mygraph node set n0 -key foobar 1
+ mygraph node set n1 -key foobar 2
+ catch {mygraph nodes -key foobar -value 1} msg
+ mygraph destroy
+ set msg
+} {n0}
# ---------------------------------------------------
