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 # RCS: @(#) $Id: comdlg.tcl,v 1.1 2006-02-24 18:59:53 vitus 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]%2) != 0} {
  56         foreach {cmdsw value} $argList {
  57             if {![info exists cmd($cmdsw)]} {
  58                 error "unknown option \"$cmdsw\", must be [tclListValidFlags cmd]"
  59             }
  60         }
  61         error "value for \"[lindex $argList end]\" missing"
  62     }
  63
  64     # 2: set the default values
  65     #
  66     foreach cmdsw [array names cmd] {
  67         set data($cmdsw) $def($cmdsw)
  68     }
  69
  70     # 3: parse the argument list
  71     #
  72     foreach {cmdsw value} $argList {
  73         if {![info exists cmd($cmdsw)]} {
  74             error "unknown option \"$cmdsw\", must be [tclListValidFlags cmd]"
  75         }
  76         set data($cmdsw) $value
  77     }
  78
  79     # Done!
  80 }
  81
  82 proc tclListValidFlags {v} {
  83     upvar $v cmd
  84
  85     set len [llength [array names cmd]]
  86     set i 1
  87     set separator ""
  88     set errormsg ""
  89     foreach cmdsw [lsort [array names cmd]] {
  90         append errormsg "$separator$cmdsw"
  91         incr i
  92         if {$i == $len} {
  93             set separator " or "
  94         } else {
  95             set separator ", "
  96         }
  97     }
  98     return $errormsg
  99 }
 100
 101 # This procedure is used to sort strings in a case-insenstive mode.
 102 #
 103 proc tclSortNoCase {str1 str2} {
 104     return [string compare [string toupper $str1] [string toupper $str2]]
 105 }
 106
 107
 108 # Gives an error if the string does not contain a valid integer
 109 # number
 110 #
 111 proc tclVerifyInteger {string} {
 112     lindex {1 2 3} $string
 113 }
 114
 115 # ckFDGetFileTypes --
 116 #
 117 #       Process the string given by the -filetypes option of the file
 118 #       dialogs. Similar to the C function TkGetFileFilters() on the Mac
 119 #       and Windows platform.
 120 #
 121 proc ckFDGetFileTypes {string} {
 122     foreach t $string {
 123         if {[llength $t] < 2 || [llength $t] > 3} {
 124             error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
 125         }
 126         eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]
 127     }
 128
 129     set types {}
 130     foreach t $string {
 131         set label [lindex $t 0]
 132         set exts {}
 133
 134         if {[info exists hasDoneType($label)]} {
 135             continue
 136         }
 137
 138         set name "$label ("
 139         set sep ""
 140         foreach ext $fileTypes($label) {
 141             if {![string compare $ext ""]} {
 142                 continue
 143             }
 144             regsub {^[.]} $ext "*." ext
 145             if {![info exists hasGotExt($label,$ext)]} {
 146                 append name $sep$ext
 147                 lappend exts $ext
 148                 set hasGotExt($label,$ext) 1
 149             }
 150             set sep ,
 151         }
 152         append name ")"
 153         lappend types [list $name $exts]
 154
 155         set hasDoneType($label) 1
 156     }
 157
 158     return $types
 159 }