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