diff options
Diffstat (limited to 'tk8.6/library/comdlg.tcl')
| -rw-r--r-- | tk8.6/library/comdlg.tcl | 319 |
1 files changed, 319 insertions, 0 deletions
diff --git a/tk8.6/library/comdlg.tcl b/tk8.6/library/comdlg.tcl new file mode 100644 index 0000000..18df8a6 --- /dev/null +++ b/tk8.6/library/comdlg.tcl @@ -0,0 +1,319 @@ +# comdlg.tcl -- +# +# Some functions needed for the common dialog boxes. Probably need to go +# in a different file. +# +# 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} { + return -code error -errorcode {TK VALUE CONFIG_SPEC} \ + "\"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)]} { + return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \ + "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" + } + return -code error -errorcode {TK VALUE_MISSING} \ + "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)]} { + return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \ + "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} { + return -code error -errorcode [list TK LOOKUP TOPLEVEL $t] \ + "$t is not a toplevel window" + } + if {![info exists Priv(fg,$t)]} { + set Priv(fg,$t) 1 + set Priv(focus,$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} { + variable FocusIn + variable ::tk::Priv + if {![info exists Priv(fg,$t)]} { + return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \ + "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)]} { + return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \ + "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 <FocusIn> 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 <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 +# 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} { + return -code error -errorcode {TK VALUE FILE_TYPE} \ + "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\"" + } + lappend 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 + } + + # Validate each macType. This is to agree with the + # behaviour of TkGetFileFilters(). This list may be + # empty. + foreach macType [lindex $t 2] { + if {[string length $macType] != 4} { + return -code error -errorcode {TK VALUE MAC_TYPE} \ + "bad Macintosh file type \"$macType\"" + } + } + + 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 +} |