CELLLINUX64/util/CELLLINUX64/lib/tk8.4/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.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 }