home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tk8.4 / comdlg.tcl < prev    next >
Text File  |  2003-02-21  |  8KB  |  312 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.9 2003/02/21 13:32:14 dkf 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. # ::tk::FocusGroup_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 ::tk::FocusGroup_Create {t} {
  123.     variable ::tk::Priv
  124.     if {[string compare [winfo toplevel $t] $t]} {
  125.     error "$t is not a toplevel window"
  126.     }
  127.     if {![info exists Priv(fg,$t)]} {
  128.     set Priv(fg,$t) 1
  129.     set Priv(focus,$t) ""
  130.     bind $t <FocusIn>  [list tk::FocusGroup_In  $t %W %d]
  131.     bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
  132.     bind $t <Destroy>  [list tk::FocusGroup_Destroy $t %W]
  133.     }
  134. }
  135.  
  136. # ::tk::FocusGroup_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 ::tk::FocusGroup_BindIn {t w cmd} {
  142.     variable FocusIn
  143.     variable ::tk::Priv
  144.     if {![info exists Priv(fg,$t)]} {
  145.     error "focus group \"$t\" doesn't exist"
  146.     }
  147.     set FocusIn($t,$w) $cmd
  148. }
  149.  
  150.  
  151. # ::tk::FocusGroup_BindOut --
  152. #
  153. #    Add a widget into the "FocusOut" list of the focus group. The
  154. #    $cmd will be called when the widget loses the focus (User
  155. #    types Tab or click on another widget).
  156. #
  157. proc ::tk::FocusGroup_BindOut {t w cmd} {
  158.     variable FocusOut
  159.     variable ::tk::Priv
  160.     if {![info exists Priv(fg,$t)]} {
  161.     error "focus group \"$t\" doesn't exist"
  162.     }
  163.     set FocusOut($t,$w) $cmd
  164. }
  165.  
  166. # ::tk::FocusGroup_Destroy --
  167. #
  168. #    Cleans up when members of the focus group is deleted, or when the
  169. #    toplevel itself gets deleted.
  170. #
  171. proc ::tk::FocusGroup_Destroy {t w} {
  172.     variable FocusIn
  173.     variable FocusOut
  174.     variable ::tk::Priv
  175.  
  176.     if {[string equal $t $w]} {
  177.     unset Priv(fg,$t)
  178.     unset Priv(focus,$t) 
  179.  
  180.     foreach name [array names FocusIn $t,*] {
  181.         unset FocusIn($name)
  182.     }
  183.     foreach name [array names FocusOut $t,*] {
  184.         unset FocusOut($name)
  185.     }
  186.     } else {
  187.     if {[info exists Priv(focus,$t)] && \
  188.         [string equal $Priv(focus,$t) $w]} {
  189.         set Priv(focus,$t) ""
  190.     }
  191.     catch {
  192.         unset FocusIn($t,$w)
  193.     }
  194.     catch {
  195.         unset FocusOut($t,$w)
  196.     }
  197.     }
  198. }
  199.  
  200. # ::tk::FocusGroup_In --
  201. #
  202. #    Handles the <FocusIn> event. Calls the FocusIn command for the newly
  203. #    focused widget in the focus group.
  204. #
  205. proc ::tk::FocusGroup_In {t w detail} {
  206.     variable FocusIn
  207.     variable ::tk::Priv
  208.  
  209.     if {[string compare $detail NotifyNonlinear] && \
  210.         [string compare $detail NotifyNonlinearVirtual]} {
  211.     # This is caused by mouse moving out&in of the window *or*
  212.     # ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
  213.     return
  214.     }
  215.     if {![info exists FocusIn($t,$w)]} {
  216.     set FocusIn($t,$w) ""
  217.     return
  218.     }
  219.     if {![info exists Priv(focus,$t)]} {
  220.     return
  221.     }
  222.     if {[string equal $Priv(focus,$t) $w]} {
  223.     # This is already in focus
  224.     #
  225.     return
  226.     } else {
  227.     set Priv(focus,$t) $w
  228.     eval $FocusIn($t,$w)
  229.     }
  230. }
  231.  
  232. # ::tk::FocusGroup_Out --
  233. #
  234. #    Handles the <FocusOut> event. Checks if this is really a lose
  235. #    focus event, not one generated by the mouse moving out of the
  236. #    toplevel window.  Calls the FocusOut command for the widget
  237. #    who loses its focus.
  238. #
  239. proc ::tk::FocusGroup_Out {t w detail} {
  240.     variable FocusOut
  241.     variable ::tk::Priv
  242.  
  243.     if {[string compare $detail NotifyNonlinear] && \
  244.         [string compare $detail 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.         error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
  269.     }
  270.     eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]
  271.     }
  272.  
  273.     set types {}
  274.     foreach t $string {
  275.     set label [lindex $t 0]
  276.     set exts {}
  277.  
  278.     if {[info exists hasDoneType($label)]} {
  279.         continue
  280.     }
  281.  
  282.     set name "$label ("
  283.     set sep ""
  284.     set doAppend 1
  285.     foreach ext $fileTypes($label) {
  286.         if {[string equal $ext ""]} {
  287.         continue
  288.         }
  289.         regsub {^[.]} $ext "*." ext
  290.         if {![info exists hasGotExt($label,$ext)]} {
  291.         if {$doAppend} {
  292.             if {[string length $sep] && [string length $name]>40} {
  293.             set doAppend 0
  294.             append name $sep...
  295.             } else {
  296.             append name $sep$ext
  297.             }
  298.         }
  299.         lappend exts $ext
  300.         set hasGotExt($label,$ext) 1
  301.         }
  302.         set sep ,
  303.     }
  304.     append name ")"
  305.     lappend types [list $name $exts]
  306.  
  307.     set hasDoneType($label) 1
  308.     }
  309.  
  310.     return $types
  311. }
  312.