comdlg.tcl –

Some functions needed for the common dialog boxes. Probably need to go

in a different file.

RCS: @(#) $Id: comdlg.tcl,v 1.9.2.1 2006/01/25 18:21:41 dgp 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.

tclParseConfigSpec –

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.

Arguments:

w = widget record to modify. Must be the pathname of a widget.

specs = {

{-commandlineswitch resourceName ResourceClass defaultValue verifier}

{….}

}

flags = currently unused.

argList = The list of “-option value” pairs.

proc tclParseConfigSpec {w specs flags argList} {
upvar #0 $w data

# 1: Put the specs in associative arrays for faster access
#
foreach spec $specs {
if {[llength $spec] < 4} {
    error "\"spec\" should contain 5 or 4 elements"
}
set cmdsw [lindex $spec 0]
set cmd($cmdsw) ""
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]"
}
set data($cmdsw) $value
}

# Done!

}

proc tclListValidFlags {v} {
upvar $v cmd

set len [llength [array names cmd]]
set i 1
set separator ""
set errormsg ""
foreach cmdsw [lsort [array names cmd]] {
append errormsg "$separator$cmdsw"
incr i
if {$i == $len} {
    set separator ", or "
} else {
    set separator ", "
}
}
return $errormsg

}

#–––––––––––––––––––––––––––––––––––

Focus Group

Focus groups are used to handle the user’s focusing actions inside a

toplevel.

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

toplevel widget.

proc ::tk::FocusGroup_Create {t} {
variable ::tk::Priv
if {[winfo toplevel $t] ne t} { error "t is not a toplevel window”
}
if {![info exists Priv(fg,t)]} { set Priv(fg,t) 1
set Priv(focus,$t) “”
bind $t [list tk::FocusGroup_In $t %W %d]
bind $t [list tk::FocusGroup_Out $t %W %d]
bind $t [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} {
variable FocusIn
variable ::tk::Priv
if {![info exists Priv(fg,t)]} { error "focus group \"t" doesn’t exist”
}
set FocusIn(t,w) $cmd
}

::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} {
variable FocusOut
variable ::tk::Priv
if {![info exists Priv(fg,t)]} { error "focus group \"t" doesn’t exist”
}
set FocusOut(t,w) $cmd
}

::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} {
variable FocusIn
variable FocusOut
variable ::tk::Priv

if {$t eq $w} {
unset Priv(fg,$t)
unset Priv(focus,$t) 

foreach name [array names FocusIn $t,*] {
    unset FocusIn($name)
}
foreach name [array names FocusOut $t,*] {
    unset FocusOut($name)
}
} else {
if {[info exists Priv(focus,$t)] && $Priv(focus,$t) eq $w} {
    set Priv(focus,$t) ""
}
unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
}

}

::tk::FocusGroup_In –

Handles the event. Calls the FocusIn command for the newly

focused widget in the focus group.

proc ::tk::FocusGroup_In {t w detail} {
variable FocusIn
variable ::tk::Priv

if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
# This is caused by mouse moving out&in of the window *or*
# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
return
}
if {![info exists FocusIn($t,$w)]} {
set FocusIn($t,$w) ""
return
}
if {![info exists Priv(focus,$t)]} {
return
}
if {$Priv(focus,$t) eq $w} {
# This is already in focus
#
return
} else {
set Priv(focus,$t) $w
eval $FocusIn($t,$w)
}

}

::tk::FocusGroup_Out –

Handles the 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

who loses its focus.

proc ::tk::FocusGroup_Out {t w detail} {
variable FocusOut
variable ::tk::Priv

if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
# This is caused by mouse moving out of the window
return
}
if {![info exists Priv(focus,$t)]} {
return
}
if {![info exists FocusOut($t,$w)]} {
return
} else {
eval $FocusOut($t,$w)
set Priv(focus,$t) ""
}

}

::tk::FDGetFileTypes –

Process the string given by the -filetypes option of the file

dialogs. Similar to the C function TkGetFileFilters() on the Mac

and Windows platform.

proc ::tk::FDGetFileTypes {string} {
foreach t $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]
}

set types {}
foreach t $string {
set label [lindex $t 0]
set exts {}

if {[info exists hasDoneType($label)]} {
    continue
}

set name "$label \("
set sep ""
set doAppend 1
foreach ext $fileTypes($label) {
    if {$ext eq ""} {
	continue
    }
    regsub {^[.]} $ext "*." ext
    if {![info exists hasGotExt($label,$ext)]} {
	if {$doAppend} {
	    if {[string length $sep] && [string length $name]>40} {
		set doAppend 0
		append name $sep...
	    } else {
		append name $sep$ext
	    }
	}
	lappend exts $ext
	set hasGotExt($label,$ext) 1
    }
    set sep ","
}
append name "\)"
lappend types [list $name $exts]

set hasDoneType($label) 1
}

return $types

}