From 3064162d9d6b976b8f052635cab3bf5def643b4b Mon Sep 17 00:00:00 2001 From: ericm Date: Tue, 1 Feb 2000 23:23:21 +0000 Subject: * library/tk.tcl: * library/tclIndex: * library/choosedir.tcl: Moved choosedir functions into the ::tk::dialog::chooseDir namespace instead of a toplevel ::tkChooseDirectory namespace. Additional cleanup on the chooseDir dialog. --- ChangeLog | 19 ++++++++ library/choosedir.tcl | 129 +++++++++++++++++++++++++++++++------------------- library/tclIndex | 2 +- library/tk.tcl | 4 +- 4 files changed, 103 insertions(+), 51 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1cfa617..f054b89 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2000-02-01 Eric Melski + + * library/tk.tcl: + * library/tclIndex: + * library/choosedir.tcl: Moved choosedir functions into the + ::tk::dialog::chooseDir namespace instead of a toplevel + ::tkChooseDirectory namespace. Additional cleanup on the + chooseDir dialog. + 2000-02-01 Jeff Hobbs * doc/text.n: clarified docs on what happens during a search with @@ -32,6 +41,16 @@ * unix/aclocal.m4: added *BSD ELF recognition for SHARED_LIB_SUFFIX determination (from Tcl's tcl.m4) +2000-01-27 Eric Melski + + * generic/tkImgPhoto.c: Removed unneccesary object translation in + MatchStringFormat (bug #4103). + +2000-01-27 Eric Melski + + * generic/tkImgGIF.c: Additional code cleanup (now we only have + one decoder! neat!) + 2000-01-26 Eric Melski * doc/getOpenFile.n: diff --git a/library/choosedir.tcl b/library/choosedir.tcl index fb92599..724b33c 100644 --- a/library/choosedir.tcl +++ b/library/choosedir.tcl @@ -6,43 +6,83 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: choosedir.tcl,v 1.1 2000/01/27 00:23:10 ericm Exp $ +# RCS: @(#) $Id: choosedir.tcl,v 1.2 2000/02/01 23:23:21 ericm Exp $ -package require opt +# Make sure the tk::dialog namespace, in which all dialogs should live, exists +namespace eval ::tk::dialog {} -namespace eval ::tkChooseDirectory { +# Make the chooseDir namespace inside the dialog namespace +namespace eval ::tk::dialog::chooseDir { + # value is an array that holds the current selection value for each dialog variable value } -::tcl::OptProc ::tkChooseDirectory::tk_chooseDirectory { - {-initialdir -string "" - "Initial directory for browser"} - {-mustexist - "If specified, user can't type in a new directory"} - {-parent -string "." - "Parent window for browser"} - {-title -string "Choose Directory" - "Title for browser window"} -} { - # Handle default directory - if {[string length $initialdir] == 0} { - set initialdir [pwd] - } +proc ::tk::dialog::chooseDir::tkChooseDirectory { args } { + variable value + # Error messages + append err(usage) "tk_chooseDirectory " + append err(usage) "?-initialdir directory? ?-mustexist? " + append err(usage) "?-parent window? ?-title title?" + + set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\"" + set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\"" + set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\"" + + # Default values + set opts(-initialdir) [pwd] + set opts(-mustexist) 0 + set opts(-parent) . + set opts(-title) "Choose Directory" + + # Process args + set len [llength $args] + for { set i 0 } { $i < $len } {incr i} { + set flag [lindex $args $i] + incr i + switch -glob -- $flag { + "-initialdir" { + if { $i >= $len } { + error [format $err(valueMissing) $flag] + } + set opts($flag) [lindex $args $i] + } + "-mustexist" { + set opts($flag) 1 + incr i -1 + } + "-parent" { + if { $i >= $len } { + error [format $err(valueMissing) $flag] + } + set opts($flag) [lindex $args $i] + } + "-title" { + if { $i >= $len } { + error [format $err(valueMissing) $flag] + } + set opts($flag) [lindex $args $i] + } + default { + error [format $err(unknownOpt) [lindex $args $i]] + } + } + } + # Handle default parent window - if {[string compare $parent "."] == 0} { - set parent "" + if {[string equal $opts(-parent) "."]} { + set opts(-parent) "" } - set w [toplevel $parent.choosedirectory] - wm title $w $title + set w [toplevel $opts(-parent).choosedirectory] + wm title $w $opts(-title) # Commands for various bindings (which follow) set okCommand [namespace code \ - [list Done $w ok ::tkChooseDirectory::value($w)]] + [list Done $w ok $opts(-mustexist)]] set cancelCommand [namespace code \ - [list Done $w cancel ::tkChooseDirectory::value($w)]] + [list Done $w cancel $opts(-mustexist)]] # Create controls. set lbl [label $w.l -text "Directory name:" -anchor w] @@ -80,7 +120,7 @@ namespace eval ::tkChooseDirectory { grid columnconfigure . 0 -weight 1 grid columnconfigure . 1 -weight 1 - $ent insert end $initialdir + $ent insert end $opts(-initialdir) # Set bindings # is the same as OK @@ -93,7 +133,7 @@ namespace eval ::tkChooseDirectory { wm protocol $w WM_DELETE_WINDOW $cancelCommand # Fill listbox and bind for browsing - Refresh $lst $initialdir + Refresh $lst $opts(-initialdir) bind $lst [namespace code [list Update $ent $lst]] bind $lst [namespace code [list Update $ent $lst]] @@ -113,13 +153,13 @@ namespace eval ::tkChooseDirectory { grab release $w - set dir $::tkChooseDirectory::value($w) - unset ::tkChooseDirectory::value($w) + set dir $value($w) + unset value($w) return $dir } # tkChooseDirectory::tk_chooseDirectory -proc ::tkChooseDirectory::MinSize { w } { +proc ::tk::dialog::chooseDir::MinSize { w } { set geometry [wm geometry $w] regexp {([0-9]*)x([0-9]*)\+} geometry whole width height @@ -127,13 +167,21 @@ proc ::tkChooseDirectory::MinSize { w } { wm minsize $w $width $height } -proc ::tkChooseDirectory::Done { w why varName } { +proc ::tk::dialog::chooseDir::Done { w why mustexist } { variable value switch -- $why { ok { - # If mustexist, validate with [cd] + # If mustexist, validate value set value($w) [$w.e get] + if { $mustexist } { + if { ![file exists $value($w)] } { + return + } + if { ![file isdirectory $value($w)] } { + return + } + } } cancel { set value($w) "" @@ -143,7 +191,7 @@ proc ::tkChooseDirectory::Done { w why varName } { destroy $w } -proc ::tkChooseDirectory::Refresh { listbox dir } { +proc ::tk::dialog::chooseDir::Refresh { listbox dir } { $listbox delete 0 end # Find the parent directory; if it is different (ie, we're not @@ -161,13 +209,13 @@ proc ::tkChooseDirectory::Refresh { listbox dir } { } } -proc ::tkChooseDirectory::Update { entry listbox } { +proc ::tk::dialog::chooseDir::Update { entry listbox } { set sel [$listbox curselection] if { [string equal $sel ""] } { return } set subdir [$listbox get $sel] - if {[string compare $subdir ".."] == 0} { + if {[string equal $subdir ".."]} { set fullpath [file dirname [$entry get]] if { [string equal $fullpath [$entry get]] } { return @@ -179,18 +227,3 @@ proc ::tkChooseDirectory::Update { entry listbox } { $entry insert end $fullpath Refresh $listbox $fullpath } - -# Some test code -if {[string compare [info script] $argv0] == 0} { - catch {rename ::tk_chooseDirectory tk_chooseDir} - - proc tk_chooseDirectory { args } { - uplevel ::tkChooseDirectory::tk_chooseDirectory $args - } - - wm withdraw . - set dir [tk_chooseDirectory -initialdir [pwd] \ - -title "Choose a directory"] - tk_messageBox -message "dir:<<$dir>>" - exit -} diff --git a/library/tclIndex b/library/tclIndex index d0d2407..5a8cb43 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -242,4 +242,4 @@ set auto_index(tkListBoxKeyAccel_Unset) [list source [file join $dir xmfbox.tcl] set auto_index(tkListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]] set auto_index(tkListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]] set auto_index(tkListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]] -set auto_index(::tkChooseDirectory::tk_chooseDirectory) [list source [file join $dir choosedir.tcl]] +set auto_index(::tk::dialog::chooseDir::tkChooseDirectory) [list source [file join $dir choosedir.tcl]] diff --git a/library/tk.tcl b/library/tk.tcl index e5347cc..be7b23e 100644 --- a/library/tk.tcl +++ b/library/tk.tcl @@ -3,7 +3,7 @@ # Initialization script normally executed in the interpreter for each # Tk-based application. Arranges class bindings for widgets. # -# RCS: @(#) $Id: tk.tcl,v 1.17 2000/01/27 00:23:10 ericm Exp $ +# RCS: @(#) $Id: tk.tcl,v 1.18 2000/02/01 23:23:21 ericm Exp $ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -256,7 +256,7 @@ if {[string equal [info commands tk_messageBox] ""]} { } if {[string equal [info command tk_chooseDirectory] ""]} { proc tk_chooseDirectory {args} { - return [eval ::tkChooseDirectory::tk_chooseDirectory $args] + return [eval ::tk::dialog::chooseDir::tkChooseDirectory $args] } } -- cgit v0.12