1  # comdlg.tcl --
  2  #
  3  #	Some functions needed for the common dialog boxes. Probably need to go
  4  #	in a different file.
  5  #
  6  # Copyright (c) 1996 Sun Microsystems, Inc.
  7  #
  8  # See the file "license.terms" for information on usage and redistribution
  9  # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 10  #
 11  
 12  # tclParseConfigSpec --
 13  #
 14  #	Parses a list of "-option value" pairs. If all options and
 15  #	values are legal, the values are stored in
 16  #	$data($option). Otherwise an error message is returned. When
 17  #	an error happens, the data() array may have been partially
 18  #	modified, but all the modified members of the data(0 array are
 19  #	guaranteed to have valid values. This is different than
 20  #	Tk_ConfigureWidget() which does not modify the value of a
 21  #	widget record if any error occurs.
 22  #
 23  # Arguments:
 24  #
 25  # w = widget record to modify. Must be the pathname of a widget.
 26  #
 27  # specs = {
 28  #    {-commandlineswitch resourceName ResourceClass defaultValue verifier}
 29  #    {....}
 30  # }
 31  #
 32  # flags = a list of flags. Currently supported flags are:
 33  #     DONTSETDEFAULTS = skip default values setting
 34  #
 35  # argList = The list of  "-option value" pairs.
 36  #
 37  proc tclParseConfigSpec {w specs flags argList} {
 38      upvar #0 $w data
 39  
 40      # 1: Put the specs in associative arrays for faster access
 41      #
 42      foreach spec $specs {
 43  	if {[llength $spec] < 4} {
 44  	    return -code error -errorcode {TK VALUE CONFIG_SPEC} \
 45  		"\"spec\" should contain 5 or 4 elements"
 46  	}
 47  	set cmdsw [lindex $spec 0]
 48  	set cmd($cmdsw) ""
 49  	set rname($cmdsw)   [lindex $spec 1]
 50  	set rclass($cmdsw)  [lindex $spec 2]
 51  	set def($cmdsw)     [lindex $spec 3]
 52  	set verproc($cmdsw) [lindex $spec 4]
 53      }
 54  
 55      if {[llength $argList] & 1} {
 56  	set cmdsw [lindex $argList end]
 57  	if {![info exists cmd($cmdsw)]} {
 58  	    return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
 59  		"bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
 60  	}
 61  	return -code error -errorcode {TK VALUE_MISSING} \
 62  	    "value for \"$cmdsw\" missing"
 63      }
 64  
 65      # 2: set the default values
 66      #
 67      if {"DONTSETDEFAULTS" ni $flags} {
 68          foreach cmdsw [array names cmd] {
 69  	    set data($cmdsw) $def($cmdsw)
 70          }
 71      }
 72  
 73      # 3: parse the argument list
 74      #
 75      foreach {cmdsw value} $argList {
 76  	if {![info exists cmd($cmdsw)]} {
 77  	    return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
 78  		"bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
 79  	}
 80  	set data($cmdsw) $value
 81      }
 82  
 83      # Done!
 84  }
 85  
 86  proc tclListValidFlags {v} {
 87      upvar $v cmd
 88  
 89      set len [llength [array names cmd]]
 90      set i 1
 91      set separator ""
 92      set errormsg ""
 93      foreach cmdsw [lsort [array names cmd]] {
 94  	append errormsg "$separator$cmdsw"
 95  	incr i
 96  	if {$i == $len} {
 97  	    set separator ", or "
 98  	} else {
 99  	    set separator ", "
100  	}
101      }
102      return $errormsg
103  }
104  
105  #----------------------------------------------------------------------
106  #
107  #			Focus Group
108  #
109  # Focus groups are used to handle the user's focusing actions inside a
110  # toplevel.
111  #
112  # One example of using focus groups is: when the user focuses on an
113  # entry, the text in the entry is highlighted and the cursor is put to
114  # the end of the text. When the user changes focus to another widget,
115  # the text in the previously focused entry is validated.
116  #
117  #----------------------------------------------------------------------
118  
119  
120  # ::tk::FocusGroup_Create --
121  #
122  #	Create a focus group. All the widgets in a focus group must be
123  #	within the same focus toplevel. Each toplevel can have only
124  #	one focus group, which is identified by the name of the
125  #	toplevel widget.
126  #
127  proc ::tk::FocusGroup_Create {t} {
128      variable ::tk::Priv
129      if {[winfo toplevel $t] ne $t} {
130  	return -code error -errorcode [list TK LOOKUP TOPLEVEL $t] \
131  	    "$t is not a toplevel window"
132      }
133      if {![info exists Priv(fg,$t)]} {
134  	set Priv(fg,$t) 1
135  	set Priv(focus,$t) ""
136  	bind $t <FocusIn>  [list tk::FocusGroup_In  $t %W %d]
137  	bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
138  	bind $t <Destroy>  [list tk::FocusGroup_Destroy $t %W]
139      }
140  }
141  
142  # ::tk::FocusGroup_BindIn --
143  #
144  # Add a widget into the "FocusIn" list of the focus group. The $cmd will be
145  # called when the widget is focused on by the user.
146  #
147  proc ::tk::FocusGroup_BindIn {t w cmd} {
148      variable FocusIn
149      variable ::tk::Priv
150      if {![info exists Priv(fg,$t)]} {
151  	return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
152  	    "focus group \"$t\" doesn't exist"
153      }
154      set FocusIn($t,$w) $cmd
155  }
156  
157  
158  # ::tk::FocusGroup_BindOut --
159  #
160  #	Add a widget into the "FocusOut" list of the focus group. The
161  #	$cmd will be called when the widget loses the focus (User
162  #	types Tab or click on another widget).
163  #
164  proc ::tk::FocusGroup_BindOut {t w cmd} {
165      variable FocusOut
166      variable ::tk::Priv
167      if {![info exists Priv(fg,$t)]} {
168  	return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
169  	    "focus group \"$t\" doesn't exist"
170      }
171      set FocusOut($t,$w) $cmd
172  }
173  
174  # ::tk::FocusGroup_Destroy --
175  #
176  #	Cleans up when members of the focus group is deleted, or when the
177  #	toplevel itself gets deleted.
178  #
179  proc ::tk::FocusGroup_Destroy {t w} {
180      variable FocusIn
181      variable FocusOut
182      variable ::tk::Priv
183  
184      if {$t eq $w} {
185  	unset Priv(fg,$t)
186  	unset Priv(focus,$t)
187  
188  	foreach name [array names FocusIn $t,*] {
189  	    unset FocusIn($name)
190  	}
191  	foreach name [array names FocusOut $t,*] {
192  	    unset FocusOut($name)
193  	}
194      } else {
195  	if {[info exists Priv(focus,$t)] && ($Priv(focus,$t) eq $w)} {
196  	    set Priv(focus,$t) ""
197  	}
198  	unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
199      }
200  }
201  
202  # ::tk::FocusGroup_In --
203  #
204  #	Handles the <FocusIn> event. Calls the FocusIn command for the newly
205  #	focused widget in the focus group.
206  #
207  proc ::tk::FocusGroup_In {t w detail} {
208      variable FocusIn
209      variable ::tk::Priv
210  
211      if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
212  	# This is caused by mouse moving out&in of the window *or*
213  	# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
214  	return
215      }
216      if {![info exists FocusIn($t,$w)]} {
217  	set FocusIn($t,$w) ""
218  	return
219      }
220      if {![info exists Priv(focus,$t)]} {
221  	return
222      }
223      if {$Priv(focus,$t) eq $w} {
224  	# This is already in focus
225  	#
226  	return
227      } else {
228  	set Priv(focus,$t) $w
229  	eval $FocusIn($t,$w)
230      }
231  }
232  
233  # ::tk::FocusGroup_Out --
234  #
235  #	Handles the <FocusOut> event. Checks if this is really a lose
236  #	focus event, not one generated by the mouse moving out of the
237  #	toplevel window.  Calls the FocusOut command for the widget
238  #	who loses its focus.
239  #
240  proc ::tk::FocusGroup_Out {t w detail} {
241      variable FocusOut
242      variable ::tk::Priv
243  
244      if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
245  	# This is caused by mouse moving out of the window
246  	return
247      }
248      if {![info exists Priv(focus,$t)]} {
249  	return
250      }
251      if {![info exists FocusOut($t,$w)]} {
252  	return
253      } else {
254  	eval $FocusOut($t,$w)
255  	set Priv(focus,$t) ""
256      }
257  }
258  
259  # ::tk::FDGetFileTypes --
260  #
261  #	Process the string given by the -filetypes option of the file
262  #	dialogs. Similar to the C function TkGetFileFilters() on the Mac
263  #	and Windows platform.
264  #
265  proc ::tk::FDGetFileTypes {string} {
266      foreach t $string {
267  	if {[llength $t] < 2 || [llength $t] > 3} {
268  	    return -code error -errorcode {TK VALUE FILE_TYPE} \
269  		"bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
270  	}
271  	lappend fileTypes([lindex $t 0]) {*}[lindex $t 1]
272      }
273  
274      set types {}
275      foreach t $string {
276  	set label [lindex $t 0]
277  	set exts {}
278  
279  	if {[info exists hasDoneType($label)]} {
280  	    continue
281  	}
282  
283  	# Validate each macType.  This is to agree with the
284  	# behaviour of TkGetFileFilters().  This list may be
285  	# empty.
286  	foreach macType [lindex $t 2] {
287  	    if {[string length $macType] != 4} {
288  		return -code error -errorcode {TK VALUE MAC_TYPE} \
289  		    "bad Macintosh file type \"$macType\""
290  	    }
291  	}
292  
293  	set name "$label \("
294  	set sep ""
295  	set doAppend 1
296  	foreach ext $fileTypes($label) {
297  	    if {$ext eq ""} {
298  		continue
299  	    }
300  	    regsub {^[.]} $ext "*." ext
301  	    if {![info exists hasGotExt($label,$ext)]} {
302  		if {$doAppend} {
303  		    if {[string length $sep] && [string length $name]>40} {
304  			set doAppend 0
305  			append name $sep...
306  		    } else {
307  			append name $sep$ext
308  		    }
309  		}
310  		lappend exts $ext
311  		set hasGotExt($label,$ext) 1
312  	    }
313  	    set sep ","
314  	}
315  	append name "\)"
316  	lappend types [list $name $exts]
317  
318  	set hasDoneType($label) 1
319      }
320  
321      return $types
322  }