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