1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
# copyright (C) 1997-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
# $Id: contain.tcl,v 1.6 2005/01/02 00:45:07 jfontain Exp $
# A simple container scheme that allows hierarchical memory data storage, can be seen as a hierarchy of named associative arrays.
# A container object has a name, can store data in an internal array and knows its children.
class container {
proc container {this {name {}}} {
::set ($this,name) $name ;# read-only member
::set ($this,children) {}
}
proc ~container {this} {
variable ${this}data
eval delete $($this,children)
catch {unset ${this}data} ;# may not exist
}
# public procedures below:
proc bind {this child} { ;# adopt and manage a child container
lappend ($this,children) $child
}
proc set {this name value} { ;# set a value in the associative array
variable ${this}data
::set ${this}data($name) $value
}
proc get {this name} { ;# retrieve a value from the associative array
variable ${this}data
return [::set ${this}data($name)]
}
proc equal {container1 container2} { ;# compare data stored in containers, including data held in children hierarchy
variable ${container1}data
variable ${container2}data
if {\
![string equal $($container1,name) $($container2,name)] ||\
([array size ${container1}data] != [array size ${container2}data]) ||\
([llength $($container1,children)] != [llength $($container2,children)])\
} {return 0} ;# stop at first trivial and fast comparison failure
foreach\
name1 [lsort -dictionary [array names ${container1}data]] name2 [lsort -dictionary [array names ${container2}data]] {
if {![string equal $name1 $name2]} {return 0}
if {![string equal [::set ${container1}data($name1)] [::set ${container2}data($name2)]]} {return 0}
}
foreach child1 $($container1,children) child2 $($container2,children) {
if {![equal $child1 $child2]} {return 0} ;# recurse with children
}
return 1
}
}
|
