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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
#
# $Id: classes_list.tcl,v 1.4 2002/10/21 22:43:14 patthoyts Exp $
#
# Written by: T. Schotanus
# E-mail: sst@bouw.tno.nl
# URL: http://huizen.dds.nl/~quintess
#
# Itcl 3.2 support by Pat Thoyts <patthoyts@users.sourceforge.net>
# We are hanging onto the older code to support old versions although
# this needs testing.
#
widget class_list {
object_include tkinspect_list
param title "Classes"
param itcl_version 0
method get_item_name {} {
return class
}
method update {target} {
$self clear
# Need info on older itcl version to do this properly.
set cmd [list if {[::info command itcl_info] != {}} {::itcl_info classes}]
set classes [lsort [send $target $cmd]]
if {$classes != {}} {
set slot(itcl_version) [send $target ::package provide Itcl]
}
foreach class $classes {
$self append $class
}
}
method retrieve {target class} {
if {$slot(itcl_version) != {}} {
if {$slot(itcl_version) >= 3} {
return [$self retrieve_new $target $class]
} else {
return [$self retrieve_old $target $class]
}
}
}
method retrieve_old {target class} {
set res "itcl_class $class {\n"
set cmd [list $class :: info inherit]
set inh [send $target $cmd]
if {$inh != ""} {
set res "$res\tinherit $inh\n\n"
} else {
set res "$res\n"
}
set pubs [send $target [list $class :: info public]]
foreach arg $pubs {
regsub {(.*)::} $arg {} a
set res "$res\tpublic $a\n"
}
if {$pubs != ""} {
set res "$res\n"
}
set prots [send $target [list $class :: info protected]]
foreach arg $prots {
regsub {(.*)::} $arg {} a
if {$a != "this"} {
set res "$res\tprotected $a\n"
}
}
if {$prots != ""} {
set res "$res\n"
}
set coms [send $target [list $class :: info common]]
foreach arg $coms {
regsub {(.*)::} $arg {} a
set cmd [list $class :: info common $a]
set com [send $target $cmd]
set res "$res\tcommon $a [list [lindex $com 2]] (default: [list [lindex $com 1]])\n"
}
if {$coms != ""} {
set res "$res\n"
}
set meths [send $target [list $class :: info method]]
foreach arg $meths {
if {[string first $class $arg] == 0} {
regsub {(.*)::} $arg {} a
set cmd [list $class :: info method $a]
set meth [send $target $cmd]
if {$a != "constructor" && $a != "destructor"} {
set nm "method "
} else {
set nm ""
}
if {[lindex $meth 1] != "<built-in>"} {
set res "$res\t$nm$a [lrange $meth 1 end]\n\n"
}
}
}
set procs [send $target [list $class :: info proc]]
foreach arg $procs {
if {[string first $class $arg] == 0} {
regsub {(.*)::} $arg {} a
set cmd [list $class :: info proc $a]
set proc [send $target $cmd]
if {[lindex $proc 1] != "<built-in>"} {
set res "$res\tproc $a [lrange $proc 1 end]\n\n"
}
}
}
set res "$res}\n"
return $res
}
method retrieve_new {target class} {
set res "itcl::class $class {\n"
set cmd [list ::namespace eval $class {info inherit}]
set inh [send $target $cmd]
if {$inh != ""} {
append res " inherit $inh\n\n"
} else {
append res "\n"
}
set vars [send $target ::namespace eval $class {info variable}]
foreach var $vars {
set name [namespace tail $var]
set cmd [list ::namespace eval $class \
[list info variable $name -protection -type -name -init]]
set text [send $target $cmd]
append res " $text\n"
}
append res "\n"
set funcs [send $target [list ::namespace eval $class {info function}]]
foreach func [lsort $funcs] {
set qualclass "::[string trimleft $class :]"
if {[string first $qualclass $func] == 0} {
set name [namespace tail $func]
set cmd [list ::namespace eval $class [list info function $name]]
set text [send $target $cmd]
if {![string match "@itcl-builtin*" [lindex $text 4]]} {
switch -exact -- $name {
constructor {
append res " $name [lrange $text 3 end]\n"
}
destructor {
append res " $name [lrange $text 4 end]\n"
}
default {
append res " [lindex $text 0] [lindex $text 1] $name\
[lrange $text 3 end]\n"
}
}
}
}
}
append res "}\n"
return $res
}
method send_filter {value} {
return $value
}
}
|
