blob: b0c19776867441ebf39208ba1fd8a20170e4847a (
plain)
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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
|
#!/bin/sh
# ----------------------------------------------------------------------
# PROGRAM: demo program for [incr Widgets]
# ----------------------------------------------------------------------
# Michael J. McLennan
# Bell Labs Innovations for Lucent Technologies
# mmclennan@lucent.com
# http://www.tcltk.com/itcl/
# ======================================================================
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
# ======================================================================
#\
exec itkwish3.0 "$0"
package require Itcl
package require Itk
package require Iwidgets 3.0
# everything else is executed by itkwish...
# ----------------------------------------------------------------------
option add *Scrolledtext.textBackground white startupFile
option add *Scrolledlistbox.textBackground white startupFile
option add *Scrolledhtml.textBackground white startupFile
option add *Scrolledhtml.padX 10 startupFile
option add *boxColor blue startupFile
option add *boxTextColor white startupFile
# ----------------------------------------------------------------------
# USAGE: iw_demo_file <name>
#
# Returns the proper demo file name for a demo called <name>.
# ----------------------------------------------------------------------
proc iw_demo_file {name} {
global iwidgets::library
return [file join $library demos $name]
}
# ----------------------------------------------------------------------
# USAGE: iw_demo_manpage <name>
#
# Returns the proper man page file for a demo called <name>.
# ----------------------------------------------------------------------
proc iw_demo_manpage {name} {
global iwidgets::library
return [file join $library demos html $name.n.html]
}
# ----------------------------------------------------------------------
# USAGE: iw_load_demo <name>
#
# Loads a demo program with the given <name>. Demos can be written
# as if they will pop up in the main application window, but they will
# pop up inside the tab notebook instead.
# ----------------------------------------------------------------------
proc iw_load_demo {name} {
global widgets
catch {eval destroy [winfo children $widgets(info-example)]}
iw_lock on
iw_status "Loading..."
set win [frame $widgets(info-example).inner]
pack $win -expand yes
set loadcmd {
set fid [open [iw_demo_file $name] r]
set code [read $fid]
close $fid
}
if {[catch $loadcmd result] == 0} {
regsub -all "(\"|\{|\\\[| |\n|^|\t)((\\.\[A-Za-z0-9\]+)+)" \
$code "\\1$win\\2" code
regsub -all "(\"|\{|\\\[| |\n|^)(\\. )" \
$code "\\1$win " code
if {[catch {uplevel #0 $code} result] == 0} {
$widgets(info-code) clear
$widgets(info-code) import [iw_demo_file $name]
iw_draw_hier $name
iw_load_manpage $name
iw_lock off
iw_status ""
return
}
}
catch {eval destroy [winfo children $win]}
label $win.err -background white -wraplength 4i \
-text "Can't load demo:\n$result"
pack $win.err -expand yes
iw_lock off
iw_status ""
}
# overload a few critical functions that might be used by demo programs...
rename exit tcl_exit
proc exit {{status 0}} {
# do nothing
}
rename puts tcl_puts
proc puts {args} {
global widgets
if {[llength $args] == 1} {
iw_status [lindex $args 0]
} else {
eval tcl_puts $args
}
}
# ----------------------------------------------------------------------
# USAGE: iw_load_manpage
#
# Loads the man page for the current demo. Man pages are not
# automatically loaded unless the man page viewer is visible.
# This procedure checks to see if the viewer is visible, and loads
# the man page if needed.
# ----------------------------------------------------------------------
set iwManPage ""
proc iw_load_manpage {{name ""}} {
global widgets iwManPage
if {[winfo ismapped $widgets(info-manpage)]} {
if {$name == ""} {
set name [$widgets(list) getcurselection]
}
if {$name != $iwManPage} {
iw_lock on
iw_status "Loading man page..."
$widgets(info-manpage) import [iw_demo_manpage $name]
iw_lock off
iw_status ""
place forget $widgets(info-manpage-feedback)
}
set iwManPage $name
}
}
# ----------------------------------------------------------------------
# USAGE: iw_manpage_progress
#
# Handles the progress meter whenever an HTML man page is rendered.
# If the progress meter is not showing, it is put up, and the current
# state is updated. If the meter is at 100%, it is taken down.
# ----------------------------------------------------------------------
proc iw_manpage_progress {n} {
global widgets remaining
if {![winfo ismapped $widgets(info-manpage-feedback)]} {
$widgets(info-manpage-feedback) configure -steps $n
$widgets(info-manpage-feedback) reset
place $widgets(info-manpage-feedback) -relx 0.5 -rely 0.5 \
-anchor c -width 200
update
set remaining $n
}
$widgets(info-manpage-feedback) step [expr $remaining - $n]
set remaining $n
}
# ----------------------------------------------------------------------
# USAGE: iw_status <message>
#
# Displays a status <message> near the top of the window.
# ----------------------------------------------------------------------
proc iw_status {message} {
global widgets
$widgets(status) configure -text $message
update
}
# ----------------------------------------------------------------------
# USAGE: iw_lock <state>
#
# Locks or unlocks the main window. Sets a grab on the main menu,
# so that all events are sent to it.
# ----------------------------------------------------------------------
proc iw_lock {state} {
global widgets
if {$state} {
grab set $widgets(mainMenu)
. configure -cursor watch
} else {
grab release $widgets(mainMenu)
. configure -cursor ""
}
}
# ----------------------------------------------------------------------
# USAGE: iw_draw_hier <name>
#
# Queries the hierarchy for a particular class in demo <name> and
# draws a class diagram into a display window. Usually invoked when
# a demo is loaded to display the class hierarchy for the associated
# widget.
# ----------------------------------------------------------------------
proc iw_draw_hier {name} {
global widgets
set canv $widgets(info-hier)
$canv delete all
set class [string toupper [string index $name 0]][string tolower [string range $name 1 end]]
if {[catch [list namespace eval iwidgets [list itcl::find classes $class]]] == 0} {
set objs [namespace eval iwidgets [list itcl::find objects -class $class]]
if {[llength $objs]} {
update idletasks
set bases [[lindex $objs 0] info heritage]
iw_draw_level [lrange $bases 1 end] $canv [lindex $bases 0]
set bbox [$canv bbox all]
$canv move all [expr [lindex $bbox 0] * -1] [expr [lindex $bbox 1] * -1]
$canv xview moveto 0
$canv yview moveto 0
set bbox [$canv bbox all]
set x [expr ([winfo width $widgets(info)] / 2) - ([lindex $bbox 2] / 2)]
set y 10
$canv move all $x $y
}
}
}
# ----------------------------------------------------------------------
# USAGE: iw_draw_level <bases> <canv> <class>
#
# Draws one level of the hierarchy for <class>.
# ----------------------------------------------------------------------
proc iw_draw_level {bases canv class} {
set org [iw_draw_box $canv $class]
set top $org
set offset 0
if {[llength $bases]} {
$canv lower [$canv create line $offset $org \
$offset [expr $top-10] \
-40 [expr $top-10] \
-24 [expr $top-10] \
-20 [expr $top-16] \
-16 [expr $top-10] \
-20 [expr $top-16] \
-20 [expr $top-26]]
$canv move all 20 [expr -($top-26+$org)]
set del [iw_draw_level [lrange $bases 1 end] $canv [lindex $bases 0]]
$canv move all -20 [expr $top-26+$org]
set top [expr $top+$del-30+$org]
incr offset 4
}
return $top
}
# ----------------------------------------------------------------------
# USAGE: iw_draw_box <canv> <class>
#
# Draws one box for a class hierarchy onto a canvas window.
# ----------------------------------------------------------------------
proc iw_draw_box {canv class} {
set bg [option get $canv boxColor BoxColor]
set textbg [option get $canv boxTextColor BoxTextColor]
set cname [string trimleft $class :]
$canv create text 0 0 -anchor center -text $cname \
-fill $textbg -tags $class
set bbox [$canv bbox $class]
set x0 [expr [lindex $bbox 0]-4]
set y0 [expr [lindex $bbox 1]-4]
set x1 [expr [lindex $bbox 2]+4]
set y1 [expr [lindex $bbox 3]+4]
$canv create rectangle $x0 $y0 $x1 $y1 \
-outline black -fill $bg
$canv raise $class
return $y0
}
# ----------------------------------------------------------------------
wm title . {[incr Widgets] Demo}
wm geometry . 750x440
frame .mbar -borderwidth 2 -relief raised
pack .mbar -fill x
set widgets(mainMenu) [menubutton .mbar.main -text "Main" -menu .mbar.main.m]
pack .mbar.main -side left
menu .mbar.main.m
.mbar.main.m add command -label "About..." -command {.about activate}
.mbar.main.m add separator
.mbar.main.m add command -label "Quit" -command tcl_exit
iwidgets::panedwindow .pw -orient vertical
pack .pw -expand yes -fill both
.pw add "widgets"
set pane [.pw childsite "widgets"]
set widgets(list) $pane.wlist
iwidgets::scrolledlistbox $widgets(list) -labeltext "Select a widget:" \
-selectioncommand {iw_load_demo [$widgets(list) getcurselection]} \
-labelpos nw -vscrollmode dynamic -hscrollmode none \
-exportselection no
pack $widgets(list) -expand yes -fill both -padx 8
.pw add "info"
set pane [.pw childsite "info"]
set widgets(info) $pane.info
.pw fraction 25 75
set widgets(status) [label $pane.status]
pack $pane.status -anchor w
iwidgets::tabnotebook $widgets(info) -tabpos s
pack $widgets(info) -expand yes -fill both
set widgets(info-example) [$widgets(info) add -label "Example"]
$widgets(info-example) configure -background white
set win [$widgets(info) add -label "Example Code"]
set widgets(info-code) [iwidgets::scrolledtext $win.code \
-wrap none -vscrollmode dynamic -hscrollmode none]
pack $widgets(info-code) -expand yes -fill both -padx 4 -pady 4
set win [$widgets(info) add -label "Inheritance"]
set widgets(info-hier) [iwidgets::scrolledcanvas $win.canv -textbackground white \
-vscrollmode dynamic -hscrollmode dynamic]
pack $widgets(info-hier) -expand yes -fill both -padx 4 -pady 4
set win [$widgets(info) add -label "Man Page"]
set widgets(info-manpage) [iwidgets::scrolledhtml $win.html \
-wrap word -vscrollmode dynamic -hscrollmode none \
-feedback "iw_manpage_progress" \
-linkcommand "$win.html import -link"]
pack $widgets(info-manpage) -expand yes -fill both -padx 4 -pady 4
set widgets(info-manpage-feedback) [iwidgets::feedback $win.html.fb \
-borderwidth 2]
bind $widgets(info-manpage) <Map> {iw_load_manpage}
$widgets(info) select "Example"
# ----------------------------------------------------------------------
# "About" window
# ----------------------------------------------------------------------
iwidgets::dialog .about -title {About: [incr Widgets] Demo} -modality none
.about hide "Apply"
.about hide "Help"
.about hide "Cancel"
.about buttonconfigure "OK" -command ".about deactivate"
.about default "OK"
set win [.about childsite]
label $win.title -text {[incr Widgets]}
pack $win.title
catch {$win.title configure -font -*-helvetica-bold-o-normal-*-*-180-*}
set file [file join ${iwidgets::library} demos iwidgets.gif]
label $win.icon -image [image create photo -file $file]
pack $win.icon -side left
label $win.by -text "Contributed By"
pack $win.by
catch {$win.by configure -font -*-helvetica-medium-r-normal-*-*-100-*}
label $win.authors -text "Mark L. Ulferts
Sue Yockey
John Sigler
Bill Scott
Alfredo Jahn
Tako Schotanus
Kris Raney
John Tucker,
Mitch Gorman
John Reekie
Ken Copeland
Tony Parent
and
Michael McLennan
"
pack $win.authors
catch {$win.authors configure -font -*-helvetica-medium-o-normal-*-*-120-*}
# ----------------------------------------------------------------------
# Load up a list of demos...
# ----------------------------------------------------------------------
foreach file [lsort [glob [file join ${iwidgets::library} demos *]]] {
set name [file tail $file]
if {![file isdirectory $file] && ![string match *.* $name]
&& ![string match catalog $name]
&& ![string match scopedobject $name]} {
if {$name == "mainwindow"} {
# This demo is doesn't work well with the catalog
# so we skip it.
continue
}
$widgets(list) insert end $name
}
}
$widgets(list) selection set 0
uplevel #0 [$widgets(list) cget -selectioncommand]
|