--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/python-2.5.2/win32/tcl/tk8.4/comdlg.tcl Fri Apr 03 17:19:34 2009 +0100
@@ -0,0 +1,311 @@
+# 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 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.
+#
+
+# 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 {[string compare [winfo toplevel $t] $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 <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)]} {
+ 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 {[string equal $t $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)] && \
+ [string equal $Priv(focus,$t) $w]} {
+ set Priv(focus,$t) ""
+ }
+ catch {
+ unset FocusIn($t,$w)
+ }
+ catch {
+ unset 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 {[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]).
+ return
+ }
+ if {![info exists FocusIn($t,$w)]} {
+ set FocusIn($t,$w) ""
+ return
+ }
+ if {![info exists Priv(focus,$t)]} {
+ return
+ }
+ if {[string equal $Priv(focus,$t) $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 {[string compare $detail NotifyNonlinear] && \
+ [string compare $detail 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 {[string equal $ext ""]} {
+ 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
+}