home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tk8.3 / comdlg.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  7.3 KB  |  298 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. # RCS: @(#) $Id: comdlg.tcl,v 1.7 2000/04/08 06:59:28 hobbs Exp $
  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 {[llength $argList] & 1} {
  56.     set cmdsw [lindex $argList end]
  57.     if {![info exists cmd($cmdsw)]} {
  58.         error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
  59.     }
  60.     error "value for \"$cmdsw\" missing"
  61.     }
  62.  
  63.     # 2: set the default values
  64.     #
  65.     foreach cmdsw [array names cmd] {
  66.     set data($cmdsw) $def($cmdsw)
  67.     }
  68.  
  69.     # 3: parse the argument list
  70.     #
  71.     foreach {cmdsw value} $argList {
  72.     if {![info exists cmd($cmdsw)]} {
  73.         error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
  74.     }
  75.     set data($cmdsw) $value
  76.     }
  77.  
  78.     # Done!
  79. }
  80.  
  81. proc tclListValidFlags {v} {
  82.     upvar $v cmd
  83.  
  84.     set len [llength [array names cmd]]
  85.     set i 1
  86.     set separator ""
  87.     set errormsg ""
  88.     foreach cmdsw [lsort [array names cmd]] {
  89.     append errormsg "$separator$cmdsw"
  90.     incr i
  91.     if {$i == $len} {
  92.         set separator ", or "
  93.     } else {
  94.         set separator ", "
  95.     }
  96.     }
  97.     return $errormsg
  98. }
  99.  
  100. #----------------------------------------------------------------------
  101. #
  102. #            Focus Group
  103. #
  104. # Focus groups are used to handle the user's focusing actions inside a
  105. # toplevel.
  106. #
  107. # One example of using focus groups is: when the user focuses on an
  108. # entry, the text in the entry is highlighted and the cursor is put to
  109. # the end of the text. When the user changes focus to another widget,
  110. # the text in the previously focused entry is validated.
  111. #
  112. #----------------------------------------------------------------------
  113.  
  114.  
  115. # tkFocusGroup_Create --
  116. #
  117. #    Create a focus group. All the widgets in a focus group must be
  118. #    within the same focus toplevel. Each toplevel can have only
  119. #    one focus group, which is identified by the name of the
  120. #    toplevel widget.
  121. #
  122. proc tkFocusGroup_Create {t} {
  123.     global tkPriv
  124.     if {[string compare [winfo toplevel $t] $t]} {
  125.     error "$t is not a toplevel window"
  126.     }
  127.     if {![info exists tkPriv(fg,$t)]} {
  128.     set tkPriv(fg,$t) 1
  129.     set tkPriv(focus,$t) ""
  130.     bind $t <FocusIn>  [list tkFocusGroup_In  $t %W %d]
  131.     bind $t <FocusOut> [list tkFocusGroup_Out $t %W %d]
  132.     bind $t <Destroy>  [list tkFocusGroup_Destroy $t %W]
  133.     }
  134. }
  135.  
  136. # tkFocusGroup_BindIn --
  137. #
  138. # Add a widget into the "FocusIn" list of the focus group. The $cmd will be
  139. # called when the widget is focused on by the user.
  140. #
  141. proc tkFocusGroup_BindIn {t w cmd} {
  142.     global tkFocusIn tkPriv
  143.     if {![info exists tkPriv(fg,$t)]} {
  144.     error "focus group \"$t\" doesn't exist"
  145.     }
  146.     set tkFocusIn($t,$w) $cmd
  147. }
  148.  
  149.  
  150. # tkFocusGroup_BindOut --
  151. #
  152. #    Add a widget into the "FocusOut" list of the focus group. The
  153. #    $cmd will be called when the widget loses the focus (User
  154. #    types Tab or click on another widget).
  155. #
  156. proc tkFocusGroup_BindOut {t w cmd} {
  157.     global tkFocusOut tkPriv
  158.     if {![info exists tkPriv(fg,$t)]} {
  159.     error "focus group \"$t\" doesn't exist"
  160.     }
  161.     set tkFocusOut($t,$w) $cmd
  162. }
  163.  
  164. # tkFocusGroup_Destroy --
  165. #
  166. #    Cleans up when members of the focus group is deleted, or when the
  167. #    toplevel itself gets deleted.
  168. #
  169. proc tkFocusGroup_Destroy {t w} {
  170.     global tkPriv tkFocusIn tkFocusOut
  171.  
  172.     if {[string equal $t $w]} {
  173.     unset tkPriv(fg,$t)
  174.     unset tkPriv(focus,$t) 
  175.  
  176.     foreach name [array names tkFocusIn $t,*] {
  177.         unset tkFocusIn($name)
  178.     }
  179.     foreach name [array names tkFocusOut $t,*] {
  180.         unset tkFocusOut($name)
  181.     }
  182.     } else {
  183.     if {[info exists tkPriv(focus,$t)] && \
  184.         [string equal $tkPriv(focus,$t) $w]} {
  185.         set tkPriv(focus,$t) ""
  186.     }
  187.     catch {
  188.         unset tkFocusIn($t,$w)
  189.     }
  190.     catch {
  191.         unset tkFocusOut($t,$w)
  192.     }
  193.     }
  194. }
  195.  
  196. # tkFocusGroup_In --
  197. #
  198. #    Handles the <FocusIn> event. Calls the FocusIn command for the newly
  199. #    focused widget in the focus group.
  200. #
  201. proc tkFocusGroup_In {t w detail} {
  202.     global tkPriv tkFocusIn
  203.  
  204.     if {[string compare $detail NotifyNonlinear] && \
  205.         [string compare $detail NotifyNonlinearVirtual]} {
  206.     # This is caused by mouse moving out&in of the window *or*
  207.     # ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
  208.     return
  209.     }
  210.     if {![info exists tkFocusIn($t,$w)]} {
  211.     set tkFocusIn($t,$w) ""
  212.     return
  213.     }
  214.     if {![info exists tkPriv(focus,$t)]} {
  215.     return
  216.     }
  217.     if {[string equal $tkPriv(focus,$t) $w]} {
  218.     # This is already in focus
  219.     #
  220.     return
  221.     } else {
  222.     set tkPriv(focus,$t) $w
  223.     eval $tkFocusIn($t,$w)
  224.     }
  225. }
  226.  
  227. # tkFocusGroup_Out --
  228. #
  229. #    Handles the <FocusOut> event. Checks if this is really a lose
  230. #    focus event, not one generated by the mouse moving out of the
  231. #    toplevel window.  Calls the FocusOut command for the widget
  232. #    who loses its focus.
  233. #
  234. proc tkFocusGroup_Out {t w detail} {
  235.     global tkPriv tkFocusOut
  236.  
  237.     if {[string compare $detail NotifyNonlinear] && \
  238.         [string compare $detail NotifyNonlinearVirtual]} {
  239.     # This is caused by mouse moving out of the window
  240.     return
  241.     }
  242.     if {![info exists tkPriv(focus,$t)]} {
  243.     return
  244.     }
  245.     if {![info exists tkFocusOut($t,$w)]} {
  246.     return
  247.     } else {
  248.     eval $tkFocusOut($t,$w)
  249.     set tkPriv(focus,$t) ""
  250.     }
  251. }
  252.  
  253. # tkFDGetFileTypes --
  254. #
  255. #    Process the string given by the -filetypes option of the file
  256. #    dialogs. Similar to the C function TkGetFileFilters() on the Mac
  257. #    and Windows platform.
  258. #
  259. proc tkFDGetFileTypes {string} {
  260.     foreach t $string {
  261.     if {[llength $t] < 2 || [llength $t] > 3} {
  262.         error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
  263.     }
  264.     eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]
  265.     }
  266.  
  267.     set types {}
  268.     foreach t $string {
  269.     set label [lindex $t 0]
  270.     set exts {}
  271.  
  272.     if {[info exists hasDoneType($label)]} {
  273.         continue
  274.     }
  275.  
  276.     set name "$label ("
  277.     set sep ""
  278.     foreach ext $fileTypes($label) {
  279.         if {[string equal $ext ""]} {
  280.         continue
  281.         }
  282.         regsub {^[.]} $ext "*." ext
  283.         if {![info exists hasGotExt($label,$ext)]} {
  284.         append name $sep$ext
  285.         lappend exts $ext
  286.         set hasGotExt($label,$ext) 1
  287.         }
  288.         set sep ,
  289.     }
  290.     append name ")"
  291.     lappend types [list $name $exts]
  292.  
  293.     set hasDoneType($label) 1
  294.     }
  295.  
  296.     return $types
  297. }
  298.