figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

comdlg.tcl (8229B)


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