# 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.5 2000/03/07 00:02:34 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 # #---------------------------------------------------------------------- catch {unset err} 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)\"" # Make a dir for us to rely on for tests makeDirectory choosedirTest set dir [pwd] set fake [file join $dir non-existant] set real [file join $dir choosedirTest] set parent . foreach opt {-initialdir -mustexist -parent -title} { test choosedir-1.1 "tk_chooseDirectory command" { list [catch {tk_chooseDirectory $opt} msg] $msg } [list 1 [format $err(valueMissing) $opt]] } test choosedir-1.2 "tk_chooseDirectory command" { list [catch {tk_chooseDirectory -foo bar} msg] $msg } [list 1 [format $err(unknownOpt) "-foo"]] test choosedir-1.3 "tk_chooseDirectory command" { list [catch {tk_chooseDirectory -parent foo.bar} msg] $msg } {1 {bad window path name "foo.bar"}} test choosedir-2.1 "tk_chooseDirectory command, cancel gives null" {unixOnly} { ToPressButton $parent cancel tk_chooseDirectory -title "Press Cancel" -parent $parent } "" test choosedir-3.1 "tk_chooseDirectory -mustexist 1" {unixOnly} { ToEnterDirByKey $parent $fake after 10 ToEnterDirByKey $parent $real tk_chooseDirectory \ -title "Enter \"$fake\", press OK, enter \"$real\", press OK" \ -parent $parent -mustexist 1 } $real test choosedir-3.2 "tk_chooseDirectory -mustexist 0" {unixOnly} { ToEnterDirByKey $parent $fake tk_chooseDirectory -title "Enter \"$fake\", press OK" \ -parent $parent -mustexist 0 } $fake test choosedir-4.1 "tk_chooseDirectory command, initialdir" {unixOnly} { ToPressButton $parent ok tk_chooseDirectory -title "Press Ok" -parent $parent -initialdir $real } $real test choosedir-4.2 "tk_chooseDirectory command, initialdir" {unixOnly} { ToEnterDirByKey $parent $fake tk_chooseDirectory \ -title "Enter \"$fake\" and press Ok" \ -parent $parent -initialdir $real } $fake test choosedir-4.3 "tk_chooseDirectory, -initialdir {}" {unixOnly} { ToPressButton $parent ok tk_chooseDirectory \ -title "Press OK" \ -parent $parent -initialdir "" } [pwd] unset err # cleanup ::tcltest::cleanupTests return