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