Jim Tcl
Check-in [5bc773bac3]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:tree: Allow nodes to be deleted

Signed-off-by: Steve Bennett <steveb@workware.net.au>

Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:5bc773bac37c94ba1bb16e150cf6fa482c3fe759
User & Date: steveb@workware.net.au 2017-08-02 23:07:24
Context
2017-08-07
10:36
expr: Check for missing operand to operator

Reported-by: Ryan Whitworth <me@ryanwhitworth.com> Signed-off-by: Steve Bennett <steveb@workware.net.au> check-in: b15d214536 user: steveb@workware.net.au tags: trunk

2017-08-02
23:07
tree: Allow nodes to be deleted

Signed-off-by: Steve Bennett <steveb@workware.net.au> check-in: 5bc773bac3 user: steveb@workware.net.au tags: trunk

23:07
Error on extra characters after close brace

In scripts, like Tcl does.

Signed-off-by: Steve Bennett <steveb@workware.net.au> Reported-by: tcler.yin check-in: df0a78320f user: steveb@workware.net.au tags: trunk

Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/tree.test.

106
107
108
109
110
111
112















113
114
115
		if {$action == "enter"} {
			lappend result [$pt get $n name]
		}
	}
	set result
} {rootnode childnode1 root.c2 root.c3 childnode2 n.c4 n.c5 n.c5.c6}
















$pt destroy

testreport







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
		if {$action == "enter"} {
			lappend result [$pt get $n name]
		}
	}
	set result
} {rootnode childnode1 root.c2 root.c3 childnode2 n.c4 n.c5 n.c5.c6}

test tree-3.1 "delete nodes" {
	$pt delete node6
	set result {}
	$pt walk root bfs {action n} {
		if {$action == "enter"} {
			lappend result [$pt get $n name]
		}
	}
	set result
} {rootnode childnode1 root.c2 root.c3 childnode2 n.c4}

test tree-3.2 "can't delete root node" -body {
	$pt delete root
} -returnCodes error -result {can't delete root node}

$pt destroy

testreport

Changes to tree.tcl.

56
57
58
59
60
61
62




63
64
65
66
67
68
69
...
150
151
152
153
154
155
156




















157
158
159
160
161
162
163
#
# $pt insert <nodename> ?index?
#
#   Add a new child node to the given node.
#   THe default index is "end"
#   Returns the name of the newly added node
#




# $pt walk <nodename> dfs|bfs {actionvar nodevar} <code>
#
#   Walks the tree starting from the given node, either breadth first (bfs)
#   depth first (dfs).
#   The value "enter" or "exit" is stored in variable $actionvar
#   The name of each node is stored in $nodevar.
#   The script $code is evaluated twice for each node, on entry and exit.
................................................................................

	# And add it as a child
	set nodes [dict get $children $node]
	dict set children $node [linsert $nodes $index $childname]

	return $childname
}





















tree method lappend {node key args} {
	if {[dict exists $tree $node $key]} {
		set result [dict get $tree $node $key]
	}
	lappend result {*}$args
	dict set tree $node $key $result







>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
...
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
#
# $pt insert <nodename> ?index?
#
#   Add a new child node to the given node.
#   THe default index is "end"
#   Returns the name of the newly added node
#
# $pt delete <nodename>
#
#   Delete the given node and all it's children.
#
# $pt walk <nodename> dfs|bfs {actionvar nodevar} <code>
#
#   Walks the tree starting from the given node, either breadth first (bfs)
#   depth first (dfs).
#   The value "enter" or "exit" is stored in variable $actionvar
#   The name of each node is stored in $nodevar.
#   The script $code is evaluated twice for each node, on entry and exit.
................................................................................

	# And add it as a child
	set nodes [dict get $children $node]
	dict set children $node [linsert $nodes $index $childname]

	return $childname
}

tree method delete {node} {
	if {$node eq "root"} {
		return -code error "can't delete root node"
	}
	$self walk $node dfs {action subnode} {
		if {$action eq "exit"} {
			# Remove the node
			dict unset tree $subnode
			# And remove as a child of our parent
			set parent [$self parent $subnode]
			if {$parent ne ""} {
				set siblings [dict get $children $parent]
				set i [lsearch $siblings $subnode]
				dict set children $parent [lreplace $siblings $i $i]
			}
		}
	}
}


tree method lappend {node key args} {
	if {[dict exists $tree $node $key]} {
		set result [dict get $tree $node $key]
	}
	lappend result {*}$args
	dict set tree $node $key $result