342 lines
11 KiB
Tcl
342 lines
11 KiB
Tcl
# ----------------------------------------------------------------------------
|
|
# dialog.tcl
|
|
# This file is part of Unifix BWidget Toolkit
|
|
# $Id: dialog.tcl,v 1.11 2002/06/04 22:27:44 hobbs Exp $
|
|
# ----------------------------------------------------------------------------
|
|
# Index of commands:
|
|
# - Dialog::create
|
|
# - Dialog::configure
|
|
# - Dialog::cget
|
|
# - Dialog::getframe
|
|
# - Dialog::add
|
|
# - Dialog::itemconfigure
|
|
# - Dialog::itemcget
|
|
# - Dialog::invoke
|
|
# - Dialog::setfocus
|
|
# - Dialog::enddialog
|
|
# - Dialog::draw
|
|
# - Dialog::withdraw
|
|
# - Dialog::_destroy
|
|
# ----------------------------------------------------------------------------
|
|
|
|
# JDC: added -transient and -place flag
|
|
|
|
namespace eval Dialog {
|
|
ButtonBox::use
|
|
|
|
Widget::bwinclude Dialog ButtonBox .bbox \
|
|
remove {-orient} \
|
|
initialize {-spacing 10 -padx 10}
|
|
|
|
Widget::declare Dialog {
|
|
{-title String "" 0}
|
|
{-geometry String "" 0}
|
|
{-modal Enum local 0 {none local global}}
|
|
{-bitmap TkResource "" 1 label}
|
|
{-image TkResource "" 1 label}
|
|
{-separator Boolean 0 1}
|
|
{-cancel Int -1 0 "%d >= -1"}
|
|
{-parent String "" 0}
|
|
{-side Enum bottom 1 {bottom left top right}}
|
|
{-anchor Enum c 1 {n e w s c}}
|
|
{-class String Dialog 1}
|
|
{-transient Boolean 1 1}
|
|
{-place Enum center 0 {none center left right above below}}
|
|
}
|
|
|
|
Widget::addmap Dialog "" :cmd {-background {}}
|
|
Widget::addmap Dialog "" .frame {-background {}}
|
|
|
|
proc ::Dialog { path args } { return [eval Dialog::create $path $args] }
|
|
proc use {} {}
|
|
|
|
bind BwDialog <Destroy> {Dialog::enddialog %W -1; Dialog::_destroy %W}
|
|
|
|
variable _widget
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::create
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::create { path args } {
|
|
global tcl_platform
|
|
variable _widget
|
|
|
|
array set maps [list Dialog {} .bbox {}]
|
|
array set maps [Widget::parseArgs Dialog $args]
|
|
|
|
# Check to see if the -class flag was specified
|
|
set dialogClass "Dialog"
|
|
array set dialogArgs $maps(Dialog)
|
|
if { [info exists dialogArgs(-class)] } {
|
|
set dialogClass $dialogArgs(-class)
|
|
}
|
|
|
|
if { [string equal $tcl_platform(platform) "unix"] } {
|
|
set re raised
|
|
set bd 1
|
|
} else {
|
|
set re flat
|
|
set bd 0
|
|
}
|
|
toplevel $path -relief $re -borderwidth $bd -class $dialogClass
|
|
|
|
Widget::initFromODB Dialog $path $maps(Dialog)
|
|
|
|
bindtags $path [list $path BwDialog all]
|
|
wm overrideredirect $path 1
|
|
wm title $path [Widget::cget $path -title]
|
|
set parent [Widget::cget $path -parent]
|
|
if { ![winfo exists $parent] } {
|
|
set parent [winfo parent $path]
|
|
}
|
|
# JDC: made transient optional
|
|
if { [Widget::getoption $path -transient] } {
|
|
wm transient $path [winfo toplevel $parent]
|
|
}
|
|
wm withdraw $path
|
|
|
|
set side [Widget::cget $path -side]
|
|
if { ![string compare $side "left"] || ![string compare $side "right"] } {
|
|
set orient vertical
|
|
} else {
|
|
set orient horizontal
|
|
}
|
|
|
|
set bbox [eval ButtonBox::create $path.bbox $maps(.bbox) -orient $orient]
|
|
set frame [frame $path.frame -relief flat -borderwidth 0]
|
|
set bg [Widget::cget $path -background]
|
|
$path configure -background $bg
|
|
$frame configure -background $bg
|
|
if { [set bitmap [Widget::getoption $path -image]] != "" } {
|
|
set label [label $path.label -image $bitmap -background $bg]
|
|
} elseif { [set bitmap [Widget::getoption $path -bitmap]] != "" } {
|
|
set label [label $path.label -bitmap $bitmap -background $bg]
|
|
}
|
|
if { [Widget::getoption $path -separator] } {
|
|
Separator::create $path.sep -orient $orient -background $bg
|
|
}
|
|
set _widget($path,realized) 0
|
|
set _widget($path,nbut) 0
|
|
|
|
bind $path <Escape> "ButtonBox::invoke $path.bbox [Widget::getoption $path -cancel]"
|
|
bind $path <Return> "ButtonBox::invoke $path.bbox default"
|
|
|
|
rename $path ::$path:cmd
|
|
proc ::$path { cmd args } "return \[eval Dialog::\$cmd $path \$args\]"
|
|
|
|
return $path
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::configure
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::configure { path args } {
|
|
set res [Widget::configure $path $args]
|
|
|
|
if { [Widget::hasChanged $path -title title] } {
|
|
wm title $path $title
|
|
}
|
|
if { [Widget::hasChanged $path -background bg] } {
|
|
if { [winfo exists $path.label] } {
|
|
$path.label configure -background $bg
|
|
}
|
|
if { [winfo exists $path.sep] } {
|
|
Separator::configure $path.sep -background $bg
|
|
}
|
|
}
|
|
return $res
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::cget
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::cget { path option } {
|
|
return [Widget::cget $path $option]
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::getframe
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::getframe { path } {
|
|
return $path.frame
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::add
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::add { path args } {
|
|
variable _widget
|
|
|
|
set res [eval ButtonBox::add $path.bbox \
|
|
-command [list "Dialog::enddialog $path $_widget($path,nbut)"] $args]
|
|
incr _widget($path,nbut)
|
|
return $res
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::itemconfigure
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::itemconfigure { path index args } {
|
|
return [eval ButtonBox::itemconfigure $path.bbox $index $args]
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::itemcget
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::itemcget { path index option } {
|
|
return [ButtonBox::itemcget $path.bbox $index $option]
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::invoke
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::invoke { path index } {
|
|
ButtonBox::invoke $path.bbox $index
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::setfocus
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::setfocus { path index } {
|
|
ButtonBox::setfocus $path.bbox $index
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::enddialog
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::enddialog { path result } {
|
|
variable _widget
|
|
|
|
set _widget($path,result) $result
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::draw
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::draw { path {focus ""} {overrideredirect 0} {geometry ""}} {
|
|
variable _widget
|
|
|
|
set parent [Widget::getoption $path -parent]
|
|
if { !$_widget($path,realized) } {
|
|
set _widget($path,realized) 1
|
|
if { [llength [winfo children $path.bbox]] } {
|
|
set side [Widget::getoption $path -side]
|
|
if { ![string compare $side "left"] || ![string compare $side "right"] } {
|
|
set pad -padx
|
|
set fill y
|
|
} else {
|
|
set pad -pady
|
|
set fill x
|
|
}
|
|
pack $path.bbox -side $side -anchor [Widget::getoption $path -anchor] -padx 1m -pady 1m
|
|
if { [winfo exists $path.sep] } {
|
|
pack $path.sep -side $side -fill $fill $pad 2m
|
|
}
|
|
}
|
|
if { [winfo exists $path.label] } {
|
|
pack $path.label -side left -anchor n -padx 3m -pady 3m
|
|
}
|
|
pack $path.frame -padx 1m -pady 1m -fill both -expand yes
|
|
}
|
|
|
|
set geom [Widget::getMegawidgetOption $path -geometry]
|
|
if { $geom != "" } {
|
|
wm geometry $path $geom
|
|
}
|
|
|
|
if { [string equal $geometry ""] && ($geom == "") } {
|
|
set place [Widget::getoption $path -place]
|
|
if { ![string equal $place none] } {
|
|
if { [winfo exists $parent] } {
|
|
BWidget::place $path 0 0 $place $parent
|
|
} else {
|
|
BWidget::place $path 0 0 $place
|
|
}
|
|
}
|
|
} else {
|
|
if { $geom != "" } {
|
|
wm geometry $path $geom
|
|
} else {
|
|
wm geometry $path $geometry
|
|
}
|
|
}
|
|
update idletasks
|
|
wm overrideredirect $path $overrideredirect
|
|
wm deiconify $path
|
|
|
|
# patch by Bastien Chevreux (bach@mwgdna.com)
|
|
# As seen on Windows systems *sigh*
|
|
# When the toplevel is withdrawn, the tkwait command will wait forever.
|
|
# So, check that we are not withdrawn
|
|
if {![winfo exists $parent] || \
|
|
([wm state [winfo toplevel $parent]] != "withdrawn")} {
|
|
tkwait visibility $path
|
|
}
|
|
BWidget::focus set $path
|
|
if { [winfo exists $focus] } {
|
|
focus -force $focus
|
|
} else {
|
|
ButtonBox::setfocus $path.bbox default
|
|
}
|
|
|
|
if { [set grab [Widget::cget $path -modal]] != "none" } {
|
|
BWidget::grab $grab $path
|
|
if {[info exists _widget($path,result)]} {
|
|
unset _widget($path,result)
|
|
}
|
|
tkwait variable Dialog::_widget($path,result)
|
|
if { [info exists _widget($path,result)] } {
|
|
set res $_widget($path,result)
|
|
unset _widget($path,result)
|
|
} else {
|
|
set res -1
|
|
}
|
|
withdraw $path
|
|
return $res
|
|
}
|
|
return ""
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::withdraw
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::withdraw { path } {
|
|
BWidget::grab release $path
|
|
BWidget::focus release $path
|
|
if { [winfo exists $path] } {
|
|
wm withdraw $path
|
|
}
|
|
}
|
|
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Command Dialog::_destroy
|
|
# ----------------------------------------------------------------------------
|
|
proc Dialog::_destroy { path } {
|
|
variable _widget
|
|
|
|
BWidget::grab release $path
|
|
BWidget::focus release $path
|
|
if {[info exists _widget($path,result)]} {
|
|
unset _widget($path,result)
|
|
}
|
|
unset _widget($path,realized)
|
|
unset _widget($path,nbut)
|
|
|
|
Widget::destroy $path
|
|
rename $path {}
|
|
}
|