215 lines
6.5 KiB
Tcl
215 lines
6.5 KiB
Tcl
|
# Procedure to create a dialog with buttons and (optionally) a title (with image if
|
||
|
|
# wanted), message (box with a message widget), and text (a text widget with
|
||
|
|
# scrollbar)
|
||
|
|
|
||
|
|
proc TKGDialog args {
|
||
|
|
global TKG TKG_strings
|
||
|
|
|
||
|
|
set name [lindex $args 0]
|
||
|
|
set wmtitle "Notice"
|
||
|
|
if [info exists TKG_strings(notice)] {
|
||
|
|
set wmtitle $TKG_strings(notice)
|
||
|
|
}
|
||
|
|
set image ""
|
||
|
|
set title ""
|
||
|
|
if [catch {
|
||
|
|
set titlebg $TKG(background)
|
||
|
|
set titlefg $TKG(foreground)
|
||
|
|
set bitmapfg $TKG(foreground)
|
||
|
|
set font $TKG(dialogfont)
|
||
|
|
}] {
|
||
|
|
set titlebg \#b0b0b0
|
||
|
|
set titlefg \#000000
|
||
|
|
set bitmapfg \#000000
|
||
|
|
set font tkgHuge
|
||
|
|
}
|
||
|
|
if {[catch {font actual $font}]} {
|
||
|
|
set font {helvetica 12}
|
||
|
|
}
|
||
|
|
set message ""
|
||
|
|
set text "-"
|
||
|
|
set buttons {}
|
||
|
|
set switches {wmtitle image title titlebg titlefg \
|
||
|
|
bitmapfg message text buttons font}
|
||
|
|
foreach switch $switches {
|
||
|
|
if { [ set i [lsearch $args "-$switch"]] != -1 } {
|
||
|
|
set $switch [lindex $args [expr $i + 1]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set oldfocus [focus]
|
||
|
|
catch {destroy .$name}
|
||
|
|
toplevel .$name
|
||
|
|
grid columnconfigure .$name 0 -weight 1
|
||
|
|
wm withdraw .$name
|
||
|
|
wm title .$name "$wmtitle"
|
||
|
|
wm minsize .$name 20 10
|
||
|
|
if { ! ( $image == "" && $title == "" ) } {
|
||
|
|
frame .$name.title -background $titlebg -relief raised -bd 1
|
||
|
|
grid columnconfigure .$name.title 1 -weight 1
|
||
|
|
if { $image != "" } {
|
||
|
|
if [regexp "bitmap (.*)" [SetImage $name-image $image] v v ] {
|
||
|
|
set imageoption "-bitmap @$v"
|
||
|
|
} else {
|
||
|
|
set imageoption "-image $name-image"
|
||
|
|
}
|
||
|
|
eval label .$name.title.icon $imageoption \
|
||
|
|
-foreground $bitmapfg -background $titlebg\
|
||
|
|
-pady 0 -borderwidth 0 -highlightthickness 0
|
||
|
|
grid .$name.title.icon -row 0 -column 0 -padx 20 -pady 6 -sticky nsew
|
||
|
|
}
|
||
|
|
if { $title != "" } {
|
||
|
|
label .$name.title.title -text "$title" \
|
||
|
|
-foreground $titlefg -background $titlebg\
|
||
|
|
-pady 0 -borderwidth 0 -highlightthickness 0
|
||
|
|
grid .$name.title.title -row 0 -column 1 -padx 6 -pady 8 -sticky nsw
|
||
|
|
}
|
||
|
|
grid .$name.title -row 0 -column 0 -sticky nsew
|
||
|
|
}
|
||
|
|
if { $message != "" } {
|
||
|
|
set textsize [TKGtextsize $message]
|
||
|
|
set textwidth [expr ([set w [lindex $textsize 0]] > 80) ? 80: $w]
|
||
|
|
set textheight [lindex $textsize 1]
|
||
|
|
text .$name.message -relief flat -borderwidth 3 \
|
||
|
|
-width $textwidth -height $textheight -wrap none -font $font
|
||
|
|
grid .$name.message -padx 10 -pady 10 -sticky nsew -row 5 -column 0
|
||
|
|
.$name.message configure -state normal
|
||
|
|
.$name.message insert end "$message"
|
||
|
|
.$name.message configure -state disabled
|
||
|
|
}
|
||
|
|
if { $text != "-" } {
|
||
|
|
frame .$name.view -relief raised -bd 1
|
||
|
|
grid columnconfigure .$name.view 0 -weight 1
|
||
|
|
grid rowconfigure .$name.view 0 -weight 1
|
||
|
|
text .$name.view.text \
|
||
|
|
-width $TKG(dialogtextwidth) -height $TKG(dialogtextheight) \
|
||
|
|
-takefocus 0 -yscrollcommand ".$name.view.scrollbar set" \
|
||
|
|
-relief sunken -borderwidth 2 -state disabled -font $font
|
||
|
|
grid .$name.view.text -row 0 -column 0 -sticky nsew -padx 5 -pady 5
|
||
|
|
scrollbar .$name.view.scrollbar -command ".$name.view.text yview"
|
||
|
|
grid .$name.view.scrollbar -row 0 -column 1 -sticky nsew -padx 5 -pady 5
|
||
|
|
grid .$name.view -row 5 -column 0 -sticky nsew
|
||
|
|
.$name.view.text configure -state normal
|
||
|
|
.$name.view.text insert end "$text"
|
||
|
|
.$name.view.text configure -state disabled
|
||
|
|
}
|
||
|
|
frame .$name.buttons -relief raised -bd 1
|
||
|
|
set i 0
|
||
|
|
foreach button $buttons {
|
||
|
|
grid columnconfigure .$name.buttons $i -weight 1
|
||
|
|
set buttonname [lindex $button 0]
|
||
|
|
button .$name.buttons.$buttonname \
|
||
|
|
-text [lindex $button 1] \
|
||
|
|
-command [lindex $button 2]
|
||
|
|
bind .$name.buttons.$buttonname <Key-Return> ".$name.buttons.$buttonname invoke"
|
||
|
|
grid .$name.buttons.$buttonname -row 0 -column $i -sticky ns -padx 10
|
||
|
|
incr i
|
||
|
|
}
|
||
|
|
if { [lsearch $args "-nodismiss"] == -1 } {
|
||
|
|
grid columnconfigure .$name.buttons $i -weight 1
|
||
|
|
button .$name.buttons.dismiss -text Dismiss \
|
||
|
|
-command "destroy .$name; catch \{focus $oldfocus\}"
|
||
|
|
bind .$name <Key-Escape> ".$name.buttons.dismiss invoke"
|
||
|
|
bind .$name <Key-Return> ".$name.buttons.dismiss invoke"
|
||
|
|
grid .$name.buttons.dismiss -row 0 -column $i -sticky ns -padx 10
|
||
|
|
}
|
||
|
|
grid .$name.buttons -row 9 -column 0 -ipadx 12 -ipady 10 -sticky nsew
|
||
|
|
grid rowconfigure .$name 5 -weight 1
|
||
|
|
grid rowconfigure .$name 0 -weight 0
|
||
|
|
grid rowconfigure .$name 9 -weight 0
|
||
|
|
catch {focus .$name.buttons.dismiss}
|
||
|
|
if { [lsearch $args "-nodeiconify"] == -1 } {
|
||
|
|
TKGCenter .$name
|
||
|
|
}
|
||
|
|
DEBUG "creating popup: .$name"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc TKGtextsize {text} {
|
||
|
|
set lines 0
|
||
|
|
set width 0
|
||
|
|
foreach line [set linelist [split $text "\n"]] {
|
||
|
|
if {$width < [set l [string length $line]]} {
|
||
|
|
set width $l
|
||
|
|
}
|
||
|
|
incr lines
|
||
|
|
}
|
||
|
|
return [list $width $lines]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc TKGTrace {info} {
|
||
|
|
TKGDialog tkgtrace \
|
||
|
|
-title "Stack Trace"\
|
||
|
|
-text "$info"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc TKGNotice {string {flag ""}} {
|
||
|
|
TKGDialog tkgnotice\
|
||
|
|
-title "tkgoodstuff Notice:"\
|
||
|
|
-message $string
|
||
|
|
}
|
||
|
|
|
||
|
|
proc TKGError {string {flag ""}} {
|
||
|
|
global errorInfo TKG
|
||
|
|
set TKG(error) 1
|
||
|
|
set info $errorInfo
|
||
|
|
# USE THIS WHEN ERROR MECHANISM IS PRODUCING ERRORS
|
||
|
|
puts "$string\n$info";return
|
||
|
|
set c {TKGDialog tkgerror\
|
||
|
|
-image warning\
|
||
|
|
-title "tkgoodstuff Error:"\
|
||
|
|
-message $string}
|
||
|
|
set b [list [list prefs "Preferences\nManager" TKGPreferences]]
|
||
|
|
if ![Empty $info] {
|
||
|
|
lappend b [list trace "Stack Trace" [list TKGTrace $info]]
|
||
|
|
}
|
||
|
|
append c " -buttons [list $b]"
|
||
|
|
eval $c
|
||
|
|
if [string match exit $flag] {
|
||
|
|
tkwait window .tkgerror
|
||
|
|
TKGQuit
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc bgerror err {TKGError $err exit}
|
||
|
|
|
||
|
|
TKGAddToHook TKG_postedhook-main-panel {proc bgerror err {TKGError $err}}
|
||
|
|
|
||
|
|
proc TKGHelp {} {
|
||
|
|
global TKG
|
||
|
|
set message "
|
||
|
|
tkgoodstuff version $TKG(version), $TKG(releasedate),
|
||
|
|
copyright 1995, 1996, and 1997 Mark Crimmins (markcrim@umich.edu).
|
||
|
|
|
||
|
|
Documentation exists only in html form. Launch the internal help
|
||
|
|
browser or $TKG(browser) to view documentation on your local system,
|
||
|
|
or launch $TKG(browser) to view the latest documentation on the
|
||
|
|
tkgoodstuff web page.
|
||
|
|
"
|
||
|
|
|
||
|
|
TKGDialog tkghelp\
|
||
|
|
-wmtitle "tkgoodstuff help"\
|
||
|
|
-title "tkgoodstuff Help"\
|
||
|
|
-buttons [subst {
|
||
|
|
{ localdoc-internal
|
||
|
|
\"Internal\nbrowser\"
|
||
|
|
{ cd $TKG(libdir)
|
||
|
|
exec ./tcl/Help.tcl $TKG(libdir)/doc/toc.html &
|
||
|
|
destroy .tkghelp
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{ localdoc-tkgbrowser
|
||
|
|
\"$TKG(browser)\"
|
||
|
|
{ TKGBrowse file:$TKG(libdir)/doc/index.html
|
||
|
|
destroy .tkghelp
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{ webdoc-tkgbrowser
|
||
|
|
\"$TKG(browser)\n(WWW)\"
|
||
|
|
{ TKGBrowse $TKG(webpage)
|
||
|
|
destroy .tkghelp
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}] \
|
||
|
|
-message $message
|
||
|
|
}
|
||
|
|
|