| 1 |
578 |
markom |
#!/bin/sh
|
| 2 |
|
|
# ----------------------------------------------------------------------
|
| 3 |
|
|
# PROGRAM: demo program for [incr Widgets]
|
| 4 |
|
|
# ----------------------------------------------------------------------
|
| 5 |
|
|
# Michael J. McLennan
|
| 6 |
|
|
# Bell Labs Innovations for Lucent Technologies
|
| 7 |
|
|
# mmclennan@lucent.com
|
| 8 |
|
|
# http://www.tcltk.com/itcl/
|
| 9 |
|
|
# ======================================================================
|
| 10 |
|
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
| 11 |
|
|
# ======================================================================
|
| 12 |
|
|
#\
|
| 13 |
|
|
exec itkwish3.0 "$0"
|
| 14 |
|
|
|
| 15 |
|
|
package require Iwidgets 3.0
|
| 16 |
|
|
|
| 17 |
|
|
# everything else is executed by itkwish...
|
| 18 |
|
|
# ----------------------------------------------------------------------
|
| 19 |
|
|
option add *Scrolledtext.textBackground white startupFile
|
| 20 |
|
|
option add *Scrolledlistbox.textBackground white startupFile
|
| 21 |
|
|
option add *Scrolledhtml.textBackground white startupFile
|
| 22 |
|
|
option add *Scrolledhtml.padX 10 startupFile
|
| 23 |
|
|
option add *boxColor blue startupFile
|
| 24 |
|
|
option add *boxTextColor white startupFile
|
| 25 |
|
|
|
| 26 |
|
|
# ----------------------------------------------------------------------
|
| 27 |
|
|
# USAGE: iw_demo_file
|
| 28 |
|
|
#
|
| 29 |
|
|
# Returns the proper demo file name for a demo called .
|
| 30 |
|
|
# ----------------------------------------------------------------------
|
| 31 |
|
|
proc iw_demo_file {name} {
|
| 32 |
|
|
global iwidgets::library
|
| 33 |
|
|
return [file join $library demos $name]
|
| 34 |
|
|
}
|
| 35 |
|
|
|
| 36 |
|
|
# ----------------------------------------------------------------------
|
| 37 |
|
|
# USAGE: iw_demo_manpage
|
| 38 |
|
|
#
|
| 39 |
|
|
# Returns the proper man page file for a demo called .
|
| 40 |
|
|
# ----------------------------------------------------------------------
|
| 41 |
|
|
proc iw_demo_manpage {name} {
|
| 42 |
|
|
global iwidgets::library
|
| 43 |
|
|
return [file join $library demos html $name.n.html]
|
| 44 |
|
|
}
|
| 45 |
|
|
|
| 46 |
|
|
# ----------------------------------------------------------------------
|
| 47 |
|
|
# USAGE: iw_load_demo
|
| 48 |
|
|
#
|
| 49 |
|
|
# Loads a demo program with the given . Demos can be written
|
| 50 |
|
|
# as if they will pop up in the main application window, but they will
|
| 51 |
|
|
# pop up inside the tab notebook instead.
|
| 52 |
|
|
# ----------------------------------------------------------------------
|
| 53 |
|
|
proc iw_load_demo {name} {
|
| 54 |
|
|
global widgets
|
| 55 |
|
|
|
| 56 |
|
|
catch {eval destroy [winfo children $widgets(info-example)]}
|
| 57 |
|
|
iw_lock on
|
| 58 |
|
|
iw_status "Loading..."
|
| 59 |
|
|
|
| 60 |
|
|
set win [frame $widgets(info-example).inner]
|
| 61 |
|
|
pack $win -expand yes
|
| 62 |
|
|
|
| 63 |
|
|
set loadcmd {
|
| 64 |
|
|
set fid [open [iw_demo_file $name] r]
|
| 65 |
|
|
set code [read $fid]
|
| 66 |
|
|
close $fid
|
| 67 |
|
|
}
|
| 68 |
|
|
if {[catch $loadcmd result] == 0} {
|
| 69 |
|
|
regsub -all "(\"|\{|\\\[| |\n|^)((\\.\[A-Za-z0-9\]+)+)" \
|
| 70 |
|
|
$code "\\1$win\\2" code
|
| 71 |
|
|
regsub -all "(\"|\{|\\\[| |\n|^)(\\. )" \
|
| 72 |
|
|
$code "\\1$win " code
|
| 73 |
|
|
if {[catch {uplevel #0 $code} result] == 0} {
|
| 74 |
|
|
$widgets(info-code) clear
|
| 75 |
|
|
$widgets(info-code) import [iw_demo_file $name]
|
| 76 |
|
|
iw_draw_hier $name
|
| 77 |
|
|
iw_load_manpage $name
|
| 78 |
|
|
iw_lock off
|
| 79 |
|
|
iw_status ""
|
| 80 |
|
|
return
|
| 81 |
|
|
}
|
| 82 |
|
|
}
|
| 83 |
|
|
catch {eval destroy [winfo children $win]}
|
| 84 |
|
|
label $win.err -background white -wraplength 4i \
|
| 85 |
|
|
-text "Can't load demo:\n$result"
|
| 86 |
|
|
pack $win.err -expand yes
|
| 87 |
|
|
iw_lock off
|
| 88 |
|
|
iw_status ""
|
| 89 |
|
|
}
|
| 90 |
|
|
|
| 91 |
|
|
# overload a few critical functions that might be used by demo programs...
|
| 92 |
|
|
rename exit tcl_exit
|
| 93 |
|
|
proc exit {{status 0}} {
|
| 94 |
|
|
# do nothing
|
| 95 |
|
|
}
|
| 96 |
|
|
|
| 97 |
|
|
rename puts tcl_puts
|
| 98 |
|
|
proc puts {args} {
|
| 99 |
|
|
global widgets
|
| 100 |
|
|
if {[llength $args] == 1} {
|
| 101 |
|
|
iw_status [lindex $args 0]
|
| 102 |
|
|
} else {
|
| 103 |
|
|
eval tcl_puts $args
|
| 104 |
|
|
}
|
| 105 |
|
|
}
|
| 106 |
|
|
|
| 107 |
|
|
# ----------------------------------------------------------------------
|
| 108 |
|
|
# USAGE: iw_load_manpage
|
| 109 |
|
|
#
|
| 110 |
|
|
# Loads the man page for the current demo. Man pages are not
|
| 111 |
|
|
# automatically loaded unless the man page viewer is visible.
|
| 112 |
|
|
# This procedure checks to see if the viewer is visible, and loads
|
| 113 |
|
|
# the man page if needed.
|
| 114 |
|
|
# ----------------------------------------------------------------------
|
| 115 |
|
|
set iwManPage ""
|
| 116 |
|
|
proc iw_load_manpage {{name ""}} {
|
| 117 |
|
|
global widgets iwManPage
|
| 118 |
|
|
|
| 119 |
|
|
if {[winfo ismapped $widgets(info-manpage)]} {
|
| 120 |
|
|
if {$name == ""} {
|
| 121 |
|
|
set name [$widgets(list) getcurselection]
|
| 122 |
|
|
}
|
| 123 |
|
|
if {$name != $iwManPage} {
|
| 124 |
|
|
iw_lock on
|
| 125 |
|
|
iw_status "Loading man page..."
|
| 126 |
|
|
$widgets(info-manpage) import [iw_demo_manpage $name]
|
| 127 |
|
|
iw_lock off
|
| 128 |
|
|
iw_status ""
|
| 129 |
|
|
}
|
| 130 |
|
|
set iwManPage $name
|
| 131 |
|
|
}
|
| 132 |
|
|
}
|
| 133 |
|
|
|
| 134 |
|
|
# ----------------------------------------------------------------------
|
| 135 |
|
|
# USAGE: iw_manpage_progress
|
| 136 |
|
|
#
|
| 137 |
|
|
# Handles the progress meter whenever an HTML man page is rendered.
|
| 138 |
|
|
# If the progress meter is not showing, it is put up, and the current
|
| 139 |
|
|
# state is updated. If the meter is at 100%, it is taken down.
|
| 140 |
|
|
# ----------------------------------------------------------------------
|
| 141 |
|
|
proc iw_manpage_progress {n max} {
|
| 142 |
|
|
global widgets
|
| 143 |
|
|
|
| 144 |
|
|
if {$n == $max} {
|
| 145 |
|
|
place forget $widgets(info-manpage-feedback)
|
| 146 |
|
|
} else {
|
| 147 |
|
|
if {![winfo ismapped $widgets(info-manpage-feedback)]} {
|
| 148 |
|
|
$widgets(info-manpage-feedback) configure -steps $max
|
| 149 |
|
|
$widgets(info-manpage-feedback) reset
|
| 150 |
|
|
place $widgets(info-manpage-feedback) -relx 0.5 -rely 0.5 -anchor c
|
| 151 |
|
|
update
|
| 152 |
|
|
}
|
| 153 |
|
|
$widgets(info-manpage-feedback) step
|
| 154 |
|
|
}
|
| 155 |
|
|
}
|
| 156 |
|
|
|
| 157 |
|
|
# ----------------------------------------------------------------------
|
| 158 |
|
|
# USAGE: iw_status
|
| 159 |
|
|
#
|
| 160 |
|
|
# Displays a status near the top of the window.
|
| 161 |
|
|
# ----------------------------------------------------------------------
|
| 162 |
|
|
proc iw_status {message} {
|
| 163 |
|
|
global widgets
|
| 164 |
|
|
$widgets(status) configure -text $message
|
| 165 |
|
|
update
|
| 166 |
|
|
}
|
| 167 |
|
|
|
| 168 |
|
|
# ----------------------------------------------------------------------
|
| 169 |
|
|
# USAGE: iw_lock
|
| 170 |
|
|
#
|
| 171 |
|
|
# Locks or unlocks the main window. Sets a grab on the main menu,
|
| 172 |
|
|
# so that all events are sent to it.
|
| 173 |
|
|
# ----------------------------------------------------------------------
|
| 174 |
|
|
proc iw_lock {state} {
|
| 175 |
|
|
global widgets
|
| 176 |
|
|
if {$state} {
|
| 177 |
|
|
grab set $widgets(mainMenu)
|
| 178 |
|
|
. configure -cursor watch
|
| 179 |
|
|
} else {
|
| 180 |
|
|
grab release $widgets(mainMenu)
|
| 181 |
|
|
. configure -cursor ""
|
| 182 |
|
|
}
|
| 183 |
|
|
}
|
| 184 |
|
|
|
| 185 |
|
|
# ----------------------------------------------------------------------
|
| 186 |
|
|
# USAGE: iw_draw_hier
|
| 187 |
|
|
#
|
| 188 |
|
|
# Queries the hierarchy for a particular class in demo and
|
| 189 |
|
|
# draws a class diagram into a display window. Usually invoked when
|
| 190 |
|
|
# a demo is loaded to display the class hierarchy for the associated
|
| 191 |
|
|
# widget.
|
| 192 |
|
|
# ----------------------------------------------------------------------
|
| 193 |
|
|
proc iw_draw_hier {name} {
|
| 194 |
|
|
global widgets
|
| 195 |
|
|
set canv $widgets(info-hier)
|
| 196 |
|
|
$canv delete all
|
| 197 |
|
|
|
| 198 |
|
|
set class [string toupper [string index $name 0]][string tolower [string range $name 1 end]]
|
| 199 |
|
|
|
| 200 |
|
|
if {[catch {namespace eval $class {info inherit}}] == 0} {
|
| 201 |
|
|
iw_draw_level $canv $class
|
| 202 |
|
|
set bbox [$canv bbox all]
|
| 203 |
|
|
$canv move all [lindex $bbox 0] [lindex $bbox 1]
|
| 204 |
|
|
update idletasks
|
| 205 |
|
|
$canv xview moveto 0
|
| 206 |
|
|
$canv yview moveto 0
|
| 207 |
|
|
}
|
| 208 |
|
|
}
|
| 209 |
|
|
|
| 210 |
|
|
# ----------------------------------------------------------------------
|
| 211 |
|
|
# USAGE: iw_draw_level
|
| 212 |
|
|
#
|
| 213 |
|
|
# Draws one level of the hierarchy for .
|
| 214 |
|
|
# ----------------------------------------------------------------------
|
| 215 |
|
|
proc iw_draw_level {canv class} {
|
| 216 |
|
|
set org [iw_draw_box $canv $class]
|
| 217 |
|
|
set top $org
|
| 218 |
|
|
|
| 219 |
|
|
set offset 0
|
| 220 |
|
|
foreach base [namespace eval $class {info inherit}] {
|
| 221 |
|
|
$canv lower [$canv create line $offset $org \
|
| 222 |
|
|
$offset [expr $top-10] \
|
| 223 |
|
|
-40 [expr $top-10] \
|
| 224 |
|
|
-24 [expr $top-10] \
|
| 225 |
|
|
-20 [expr $top-16] \
|
| 226 |
|
|
-16 [expr $top-10] \
|
| 227 |
|
|
-20 [expr $top-16] \
|
| 228 |
|
|
-20 [expr $top-26]]
|
| 229 |
|
|
$canv move all 20 [expr -($top-26+$org)]
|
| 230 |
|
|
set del [iw_draw_level $canv $base]
|
| 231 |
|
|
$canv move all -20 [expr $top-26+$org]
|
| 232 |
|
|
set top [expr $top+$del-30+$org]
|
| 233 |
|
|
incr offset 4
|
| 234 |
|
|
}
|
| 235 |
|
|
return $top
|
| 236 |
|
|
}
|
| 237 |
|
|
|
| 238 |
|
|
# ----------------------------------------------------------------------
|
| 239 |
|
|
# USAGE: iw_draw_box
|
| 240 |
|
|
#
|
| 241 |
|
|
# Draws one box for a class hierarchy onto a canvas window.
|
| 242 |
|
|
# ----------------------------------------------------------------------
|
| 243 |
|
|
proc iw_draw_box {canv class} {
|
| 244 |
|
|
set bg [option get $canv boxColor BoxColor]
|
| 245 |
|
|
set textbg [option get $canv boxTextColor BoxTextColor]
|
| 246 |
|
|
|
| 247 |
|
|
set cname [string trimleft $class :]
|
| 248 |
|
|
$canv create text 0 0 -anchor center -text $cname \
|
| 249 |
|
|
-fill $textbg -tags $class
|
| 250 |
|
|
|
| 251 |
|
|
set bbox [$canv bbox $class]
|
| 252 |
|
|
set x0 [expr [lindex $bbox 0]-4]
|
| 253 |
|
|
set y0 [expr [lindex $bbox 1]-4]
|
| 254 |
|
|
set x1 [expr [lindex $bbox 2]+4]
|
| 255 |
|
|
set y1 [expr [lindex $bbox 3]+4]
|
| 256 |
|
|
|
| 257 |
|
|
$canv create rectangle $x0 $y0 $x1 $y1 \
|
| 258 |
|
|
-outline black -fill $bg
|
| 259 |
|
|
|
| 260 |
|
|
$canv raise $class
|
| 261 |
|
|
|
| 262 |
|
|
return $y0
|
| 263 |
|
|
}
|
| 264 |
|
|
|
| 265 |
|
|
# ----------------------------------------------------------------------
|
| 266 |
|
|
wm title . {[incr Widgets] Demo}
|
| 267 |
|
|
wm geometry . 620x440
|
| 268 |
|
|
|
| 269 |
|
|
frame .mbar -borderwidth 2 -relief raised
|
| 270 |
|
|
pack .mbar -fill x
|
| 271 |
|
|
set widgets(mainMenu) [menubutton .mbar.main -text "Main" -menu .mbar.main.m]
|
| 272 |
|
|
pack .mbar.main -side left
|
| 273 |
|
|
|
| 274 |
|
|
menu .mbar.main.m
|
| 275 |
|
|
.mbar.main.m add command -label "About..." -command {.about activate}
|
| 276 |
|
|
.mbar.main.m add separator
|
| 277 |
|
|
.mbar.main.m add command -label "Quit" -command tcl_exit
|
| 278 |
|
|
|
| 279 |
|
|
iwidgets::panedwindow .pw -orient vertical
|
| 280 |
|
|
pack .pw -expand yes -fill both
|
| 281 |
|
|
|
| 282 |
|
|
.pw add "widgets"
|
| 283 |
|
|
set pane [.pw childsite "widgets"]
|
| 284 |
|
|
set widgets(list) $pane.wlist
|
| 285 |
|
|
|
| 286 |
|
|
iwidgets::scrolledlistbox $widgets(list) -labeltext "Select a widget:" \
|
| 287 |
|
|
-selectioncommand {iw_load_demo [$widgets(list) getcurselection]} \
|
| 288 |
|
|
-labelpos nw -vscrollmode dynamic -hscrollmode none \
|
| 289 |
|
|
-exportselection no
|
| 290 |
|
|
pack $widgets(list) -expand yes -fill both -padx 8
|
| 291 |
|
|
|
| 292 |
|
|
.pw add "info"
|
| 293 |
|
|
set pane [.pw childsite "info"]
|
| 294 |
|
|
set widgets(info) $pane.info
|
| 295 |
|
|
|
| 296 |
|
|
set widgets(status) [label $pane.status]
|
| 297 |
|
|
pack $pane.status -anchor w
|
| 298 |
|
|
|
| 299 |
|
|
iwidgets::tabnotebook $widgets(info) -tabpos s
|
| 300 |
|
|
pack $widgets(info) -expand yes -fill both
|
| 301 |
|
|
|
| 302 |
|
|
set widgets(info-example) [$widgets(info) add -label "Example"]
|
| 303 |
|
|
$widgets(info-example) configure -background white
|
| 304 |
|
|
|
| 305 |
|
|
set win [$widgets(info) add -label "Example Code"]
|
| 306 |
|
|
set widgets(info-code) [iwidgets::scrolledtext $win.code \
|
| 307 |
|
|
-wrap none -vscrollmode dynamic -hscrollmode none]
|
| 308 |
|
|
pack $widgets(info-code) -expand yes -fill both -padx 4 -pady 4
|
| 309 |
|
|
|
| 310 |
|
|
set win [$widgets(info) add -label "Inheritance"]
|
| 311 |
|
|
set widgets(info-hier) [iwidgets::scrolledcanvas $win.canv -textbackground white \
|
| 312 |
|
|
-vscrollmode dynamic -hscrollmode dynamic]
|
| 313 |
|
|
pack $widgets(info-hier) -expand yes -fill both -padx 4 -pady 4
|
| 314 |
|
|
|
| 315 |
|
|
set win [$widgets(info) add -label "Man Page"]
|
| 316 |
|
|
set widgets(info-manpage) [iwidgets::scrolledhtml $win.html \
|
| 317 |
|
|
-wrap word -vscrollmode dynamic -hscrollmode none \
|
| 318 |
|
|
-feedback "iw_manpage_progress" \
|
| 319 |
|
|
-linkcommand "$win.html import -link"]
|
| 320 |
|
|
pack $widgets(info-manpage) -expand yes -fill both -padx 4 -pady 4
|
| 321 |
|
|
|
| 322 |
|
|
set widgets(info-manpage-feedback) [iwidgets::feedback $win.html.fb \
|
| 323 |
|
|
-borderwidth 2 -relief raised]
|
| 324 |
|
|
|
| 325 |
|
|
bind $widgets(info-manpage)
|
| 326 |
|
|
|
| 327 |
|
|
.pw fraction 25 75
|
| 328 |
|
|
$widgets(info) select "Example"
|
| 329 |
|
|
|
| 330 |
|
|
# ----------------------------------------------------------------------
|
| 331 |
|
|
# "About" window
|
| 332 |
|
|
# ----------------------------------------------------------------------
|
| 333 |
|
|
iwidgets::dialog .about -title {About: [incr Widgets] Demo} -modality none
|
| 334 |
|
|
.about hide "Apply"
|
| 335 |
|
|
.about hide "Help"
|
| 336 |
|
|
.about hide "Cancel"
|
| 337 |
|
|
.about buttonconfigure "OK" -command ".about deactivate"
|
| 338 |
|
|
.about default "OK"
|
| 339 |
|
|
|
| 340 |
|
|
set win [.about childsite]
|
| 341 |
|
|
label $win.title -text {[incr Widgets]}
|
| 342 |
|
|
pack $win.title
|
| 343 |
|
|
catch {$win.title configure -font -*-helvetica-bold-o-normal-*-*-180-*}
|
| 344 |
|
|
|
| 345 |
|
|
set file [file join ${iwidgets::library} demos iwidgets.gif]
|
| 346 |
|
|
label $win.icon -image [image create photo -file $file]
|
| 347 |
|
|
pack $win.icon -side left
|
| 348 |
|
|
|
| 349 |
|
|
label $win.by -text "Contributed By"
|
| 350 |
|
|
pack $win.by
|
| 351 |
|
|
catch {$win.by configure -font -*-helvetica-medium-r-normal-*-*-100-*}
|
| 352 |
|
|
|
| 353 |
|
|
label $win.authors -text "Mark L. Ulferts
|
| 354 |
|
|
Sue Yockey
|
| 355 |
|
|
John Sigler
|
| 356 |
|
|
Bill Scott
|
| 357 |
|
|
Alfredo Jahn
|
| 358 |
|
|
Tako Schotanus
|
| 359 |
|
|
Kris Raney"
|
| 360 |
|
|
pack $win.authors
|
| 361 |
|
|
catch {$win.authors configure -font -*-helvetica-medium-o-normal-*-*-120-*}
|
| 362 |
|
|
|
| 363 |
|
|
# ----------------------------------------------------------------------
|
| 364 |
|
|
# Load up a list of demos...
|
| 365 |
|
|
# ----------------------------------------------------------------------
|
| 366 |
|
|
foreach file [lsort [glob [file join ${iwidgets::library} demos *]]] {
|
| 367 |
|
|
set name [file tail $file]
|
| 368 |
|
|
if {![file isdirectory $file] && ![string match *.* $name]} {
|
| 369 |
|
|
$widgets(list) insert end $name
|
| 370 |
|
|
}
|
| 371 |
|
|
}
|
| 372 |
|
|
$widgets(list) selection set 0
|
| 373 |
|
|
uplevel #0 [$widgets(list) cget -selectioncommand]
|
