mingw/lib/tk8.5/comdlg.tcl

   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.14 2007/05/16 18:10:35 dgp 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 {[winfo toplevel $t] ne $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 {$t eq $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)] && ($Priv(focus,$t) eq $w)} {
 188             set Priv(focus,$t) ""
 189         }
 190         unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
 191     }
 192 }
 193
 194 # ::tk::FocusGroup_In --
 195 #
 196 #       Handles the <FocusIn> event. Calls the FocusIn command for the newly
 197 #       focused widget in the focus group.
 198 #
 199 proc ::tk::FocusGroup_In {t w detail} {
 200     variable FocusIn
 201     variable ::tk::Priv
 202
 203     if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
 204         # This is caused by mouse moving out&in of the window *or*
 205         # ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
 206         return
 207     }
 208     if {![info exists FocusIn($t,$w)]} {
 209         set FocusIn($t,$w) ""
 210         return
 211     }
 212     if {![info exists Priv(focus,$t)]} {
 213         return
 214     }
 215     if {$Priv(focus,$t) eq $w} {
 216         # This is already in focus
 217         #
 218         return
 219     } else {
 220         set Priv(focus,$t) $w
 221         eval $FocusIn($t,$w)
 222     }
 223 }
 224
 225 # ::tk::FocusGroup_Out --
 226 #
 227 #       Handles the <FocusOut> event. Checks if this is really a lose
 228 #       focus event, not one generated by the mouse moving out of the
 229 #       toplevel window.  Calls the FocusOut command for the widget
 230 #       who loses its focus.
 231 #
 232 proc ::tk::FocusGroup_Out {t w detail} {
 233     variable FocusOut
 234     variable ::tk::Priv
 235
 236     if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
 237         # This is caused by mouse moving out of the window
 238         return
 239     }
 240     if {![info exists Priv(focus,$t)]} {
 241         return
 242     }
 243     if {![info exists FocusOut($t,$w)]} {
 244         return
 245     } else {
 246         eval $FocusOut($t,$w)
 247         set Priv(focus,$t) ""
 248     }
 249 }
 250
 251 # ::tk::FDGetFileTypes --
 252 #
 253 #       Process the string given by the -filetypes option of the file
 254 #       dialogs. Similar to the C function TkGetFileFilters() on the Mac
 255 #       and Windows platform.
 256 #
 257 proc ::tk::FDGetFileTypes {string} {
 258     foreach t $string {
 259         if {[llength $t] < 2 || [llength $t] > 3} {
 260             error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
 261         }
 262         lappend fileTypes([lindex $t 0]) {*}[lindex $t 1]
 263     }
 264
 265     set types {}
 266     foreach t $string {
 267         set label [lindex $t 0]
 268         set exts {}
 269
 270         if {[info exists hasDoneType($label)]} {
 271             continue
 272         }
 273
 274         # Validate each macType.  This is to agree with the
 275         # behaviour of TkGetFileFilters().  This list may be
 276         # empty.
 277         foreach macType [lindex $t 2] {
 278             if {[string length $macType] != 4} {
 279                 error "bad Macintosh file type \"$macType\""
 280             }
 281         }
 282
 283         set name "$label \("
 284         set sep ""
 285         set doAppend 1
 286         foreach ext $fileTypes($label) {
 287             if {$ext eq ""} {
 288                 continue
 289             }
 290             regsub {^[.]} $ext "*." ext
 291             if {![info exists hasGotExt($label,$ext)]} {
 292                 if {$doAppend} {
 293                     if {[string length $sep] && [string length $name]>40} {
 294                         set doAppend 0
 295                         append name $sep...
 296                     } else {
 297                         append name $sep$ext
 298                     }
 299                 }
 300                 lappend exts $ext
 301                 set hasGotExt($label,$ext) 1
 302             }
 303             set sep ","
 304         }
 305         append name "\)"
 306         lappend types [list $name $exts]
 307
 308         set hasDoneType($label) 1
 309     }
 310
 311     return $types
 312 }