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
175
176
177
178
179
|
#
# $Id: objects_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 object_list {
object_include tkinspect_list
param title "Objects"
param itcl_version 0
method get_item_name {} {
return object
}
method update {target} {
$self clear
set cmd [list if {[::info command itcl_info] != {}} {itcl_info objects}]
set objects [lsort [send $target $cmd]]
if {$objects != {}} {
set slot(itcl_version) [send $target ::package provide Itcl]
}
foreach object $objects {
$self append $object
}
}
method retrieve {target object} {
if {$slot(itcl_version) != {}} {
if {$slot(itcl_version) >= 3} {
return [$self retrieve_new $target $object]
} else {
return [$self retrieve_old $target $object]
}
}
}
method retrieve_old {target object} {
set class [send $target [list $object info class]]
set res "$class $object {\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 $object info public]]
foreach arg $pubs {
regsub {(.*)::} $arg {} a
set cmd [list $object info public $a]
set pub [send $target $cmd]
set res "$res\tpublic $a [list [lindex $pub 2] [lindex $pub 3]] (default: [list [lindex $pub 1]])\n"
}
if {$pubs != ""} {
set res "$res\n"
}
set prots [send $target [list $object info protected]]
foreach arg $prots {
regsub {(.*)::} $arg {} a
if {$a == "this"} {
continue
}
set cmd [list $object info protected $a]
set prot [send $target $cmd]
set res "$res\tprotected $a [list [lindex $prot 2]] (default: [list [lindex $prot 1]])\n"
}
if {$prots != ""} {
set res "$res\n"
}
set coms [send $target [list $object info common]]
foreach arg $coms {
regsub {(.*)::} $arg {} a
set cmd [list $object 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 $object info method]]
foreach arg $meths {
if {[string first $class $arg] == 0} {
regsub {(.*)::} $arg {} a
set cmd [list $object 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 $object info proc]]
foreach arg $procs {
if {[string first $class $arg] == 0} {
regsub {(.*)::} $arg {} a
set cmd [list $object 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 object} {
set class [send $target [list $object info class]]
set res "$class $object {\n"
set cmd [list $object info inherit]
set inh [send $target $cmd]
if {$inh != ""} {
append res " inherit $inh\n\n"
} else {
append res "\n"
}
set vars [send $target $object info variable]
foreach var $vars {
set name [namespace tail $var]
set cmd [list $object info variable $name]
set text [send $target $cmd]
append res " $text\n"
}
append res "\n"
set funcs [send $target [list $object 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 $object 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
}
}
|
