# Some functions needed for the common dialog boxes. Probably need to go
# RCS: @(#) $Id: comdlg.tcl,v 1.9 2003/02/21 13:32:14 dkf Exp $
# Copyright (c) 1996 Sun Microsystems, Inc.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Parses a list of "-option value" pairs. If all options and
# values are legal, the values are stored in
# $data($option). Otherwise an error message is returned. When
# an error happens, the data() array may have been partially
# modified, but all the modified members of the data(0 array are
# guaranteed to have valid values. This is different than
# Tk_ConfigureWidget() which does not modify the value of a
# widget record if any error occurs.
# w = widget record to modify. Must be the pathname of a widget.
# {-commandlineswitch resourceName ResourceClass defaultValue verifier}
# flags = currently unused.
# argList = The list of "-option value" pairs.
proc tclParseConfigSpec
{w specs flags argList
} {
# 1: Put the specs in associative arrays for faster access
if {[llength $spec] < 4} {
error "\"spec\" should contain 5 or 4 elements"
set cmdsw
[lindex $spec 0]
set rname
($cmdsw) [lindex $spec 1]
set rclass
($cmdsw) [lindex $spec 2]
set def
($cmdsw) [lindex $spec 3]
set verproc
($cmdsw) [lindex $spec 4]
if {[llength $argList] & 1} {
set cmdsw
[lindex $argList end
]
if {![info exists cmd
($cmdsw)]} {
error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
error "value for \"$cmdsw\" missing"
# 2: set the default values
foreach cmdsw
[array names cmd
] {
set data
($cmdsw) $def($cmdsw)
# 3: parse the argument list
foreach {cmdsw value
} $argList {
if {![info exists cmd
($cmdsw)]} {
error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
proc tclListValidFlags
{v
} {
set len
[llength [array names cmd
]]
foreach cmdsw
[lsort [array names cmd
]] {
append errormsg
"$separator$cmdsw"
#----------------------------------------------------------------------
# Focus groups are used to handle the user's focusing actions inside a
# One example of using focus groups is: when the user focuses on an
# entry, the text in the entry is highlighted and the cursor is put to
# the end of the text. When the user changes focus to another widget,
# the text in the previously focused entry is validated.
#----------------------------------------------------------------------
# ::tk::FocusGroup_Create --
# Create a focus group. All the widgets in a focus group must be
# within the same focus toplevel. Each toplevel can have only
# one focus group, which is identified by the name of the
proc ::tk::FocusGroup_Create {t
} {
if {[string compare
[winfo toplevel $t] $t]} {
error "$t is not a toplevel window"
if {![info exists Priv
(fg
,$t)]} {
bind $t <FocusIn
> [list tk::FocusGroup_In $t %W
%d
]
bind $t <FocusOut
> [list tk::FocusGroup_Out $t %W
%d
]
bind $t <Destroy
> [list tk::FocusGroup_Destroy $t %W
]
# ::tk::FocusGroup_BindIn --
# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
# called when the widget is focused on by the user.
proc ::tk::FocusGroup_BindIn {t w cmd
} {
if {![info exists Priv
(fg
,$t)]} {
error "focus group \"$t\" doesn't exist"
# ::tk::FocusGroup_BindOut --
# Add a widget into the "FocusOut" list of the focus group. The
# $cmd will be called when the widget loses the focus (User
# types Tab or click on another widget).
proc ::tk::FocusGroup_BindOut {t w cmd
} {
if {![info exists Priv
(fg
,$t)]} {
error "focus group \"$t\" doesn't exist"
# ::tk::FocusGroup_Destroy --
# Cleans up when members of the focus group is deleted, or when the
# toplevel itself gets deleted.
proc ::tk::FocusGroup_Destroy {t w
} {
if {[string equal
$t $w]} {
foreach name
[array names FocusIn
$t,*] {
foreach name
[array names FocusOut
$t,*] {
if {[info exists Priv
(focus,$t)] && \
[string equal
$Priv(focus,$t) $w]} {
# Handles the <FocusIn> event. Calls the FocusIn command for the newly
# focused widget in the focus group.
proc ::tk::FocusGroup_In {t w detail
} {
if {[string compare
$detail NotifyNonlinear
] && \
[string compare
$detail NotifyNonlinearVirtual
]} {
# This is caused by mouse moving out&in of the window *or*
# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
if {![info exists FocusIn
($t,$w)]} {
if {![info exists Priv
(focus,$t)]} {
if {[string equal
$Priv(focus,$t) $w]} {
# This is already in focus
# ::tk::FocusGroup_Out --
# Handles the <FocusOut> event. Checks if this is really a lose
# focus event, not one generated by the mouse moving out of the
# toplevel window. Calls the FocusOut command for the widget
proc ::tk::FocusGroup_Out {t w detail
} {
if {[string compare
$detail NotifyNonlinear
] && \
[string compare
$detail NotifyNonlinearVirtual
]} {
# This is caused by mouse moving out of the window
if {![info exists Priv
(focus,$t)]} {
if {![info exists FocusOut
($t,$w)]} {
# ::tk::FDGetFileTypes --
# Process the string given by the -filetypes option of the file
# dialogs. Similar to the C function TkGetFileFilters() on the Mac
proc ::tk::FDGetFileTypes {string} {
if {[llength $t] < 2 ||
[llength $t] > 3} {
error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
eval lappend [list fileTypes
([lindex $t 0])] [lindex $t 1]
if {[info exists hasDoneType
($label)]} {
foreach ext
$fileTypes($label) {
if {[string equal
$ext ""]} {
regsub {^
[.
]} $ext "*." ext
if {![info exists hasGotExt
($label,$ext)]} {
if {[string length
$sep] && [string length
$name]>40} {
set hasGotExt
($label,$ext) 1
lappend types
[list $name $exts]
set hasDoneType
($label) 1