From 3539ffc10ed8dfe6d3cc40b16493e82511545759 Mon Sep 17 00:00:00 2001 From: ericm Date: Mon, 14 Feb 2000 22:00:17 +0000 Subject: Fixed handling of -mustexist flag for tk_chooseDirectory. --- library/choosedir.tcl | 35 ++++++--------- tests/choosedir.test | 122 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 135 insertions(+), 22 deletions(-) create mode 100644 tests/choosedir.test diff --git a/library/choosedir.tcl b/library/choosedir.tcl index 724b33c..6ccbb9f 100644 --- a/library/choosedir.tcl +++ b/library/choosedir.tcl @@ -6,7 +6,7 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: choosedir.tcl,v 1.2 2000/02/01 23:23:21 ericm Exp $ +# RCS: @(#) $Id: choosedir.tcl,v 1.3 2000/02/14 22:00:17 ericm Exp $ # Make sure the tk::dialog namespace, in which all dialogs should live, exists namespace eval ::tk::dialog {} @@ -22,12 +22,13 @@ proc ::tk::dialog::chooseDir::tkChooseDirectory { args } { # Error messages append err(usage) "tk_chooseDirectory " - append err(usage) "?-initialdir directory? ?-mustexist? " + append err(usage) "?-initialdir directory? ?-mustexist boolean? " 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)\"" + set err(badWindow) "bad window path name \"%s\"" # Default values set opts(-initialdir) [pwd] @@ -40,36 +41,26 @@ proc ::tk::dialog::chooseDir::tkChooseDirectory { args } { for { set i 0 } { $i < $len } {incr i} { set flag [lindex $args $i] incr i + if { $i >= $len } { + error [format $err(valueMissing) $flag] + } 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] - } + "-initialdir" - + "-mustexist" - + "-parent" - "-title" { - if { $i >= $len } { - error [format $err(valueMissing) $flag] - } set opts($flag) [lindex $args $i] } default { - error [format $err(unknownOpt) [lindex $args $i]] + error [format $err(unknownOpt) $flag] } } } # Handle default parent window + if { ![winfo exists $opts(-parent)] } { + error [format $err(badWindow) $opts(-parent)] + } if {[string equal $opts(-parent) "."]} { set opts(-parent) "" } diff --git a/tests/choosedir.test b/tests/choosedir.test new file mode 100644 index 0000000..3f88147 --- /dev/null +++ b/tests/choosedir.test @@ -0,0 +1,122 @@ +# This file is a Tcl script to test out Tk's "tk_chooseDir" and +# It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: choosedir.test,v 1.1 2000/02/14 22:00:17 ericm Exp $ +# + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import ::tcltest::* +} + +#---------------------------------------------------------------------- +# +# Procedures needed by this test file +# +#---------------------------------------------------------------------- + +proc ToPressButton {parent btn} { + after 100 SendButtonPress $parent $btn mouse +} + +proc ToEnterDirByKey {parent dir} { + after 100 EnterDirByKey $parent [list $dir] +} + +proc PressButton {btn} { + event generate $btn + event generate $btn <1> -x 5 -y 5 + event generate $btn -x 5 -y 5 +} + +proc EnterDirByKey {parent dir} { + if {$parent == "."} { + set w .choosedirectory + } else { + set w $parent.choosedirectory + } + + $w.e delete 0 end + $w.e insert 0 $dir + + update + SendButtonPress $parent ok mouse +} + +proc SendButtonPress {parent btn type} { + if {$parent == "."} { + set w .choosedirectory + } else { + set w $parent.choosedirectory + } + + set button $w.$btn + if ![winfo ismapped $button] { + update + } + + if {$type == "mouse"} { + PressButton $button + } else { + event generate $w + focus $w + event generate $button + event generate $w -keysym Return + } +} + + +#---------------------------------------------------------------------- +# +# The test suite proper +# +#---------------------------------------------------------------------- + +append err(usage) "tk_chooseDirectory " +append err(usage) "?-initialdir directory? ?-mustexist boolean? " +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)\"" + +foreach opt {-initialdir -mustexist -parent -title} { + test filebox-1.1 "tk_chooseDirectory command" { + list [catch {tk_chooseDirectory $opt} msg] $msg + } [list 1 [format $err(valueMissing) $opt]] +} +test filebox-1.2 "tk_chooseDirectory command" { + list [catch {tk_chooseDirectory -foo bar} msg] $msg +} [list 1 [format $err(unknownOpt) "-foo"]] +test filebox-1.3 "tk_chooseDirectory command" { + list [catch {tk_chooseDirectory -parent foo.bar} msg] $msg +} {1 {bad window path name "foo.bar"}} + +set parent . +set initialdir [pwd] +set pathName [pwd] +set otherdir "/tmp" + +test filebox-2.1 "tk_chooseDirectory command" {unixOnly} { + ToPressButton $parent cancel + tk_chooseDirectory -title "Press Cancel" -parent $parent +} "" +test filebox-2.2 "tk_chooseDirectory command" {unixOnly} { + ToPressButton $parent ok + set choice [tk_chooseDirectory -title "Press Ok" \ + -parent $parent -initialdir $initialdir] +} $initialdir +test filebox-2.3 "tk_chooseDirectory command" {unixOnly} { + ToEnterDirByKey $parent $otherdir + set choice [tk_chooseDirectory \ + -title "Enter \"$otherdir\" and press Ok" \ + -parent $parent -initialdir $initialdir] +} $otherdir + +# cleanup +::tcltest::cleanupTests +return -- cgit v0.12