File: choosedir.test

package info (click to toggle)
saods9 3.0.3-1
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 86,868 kB
  • ctags: 82,021
  • sloc: ansic: 663,637; tcl: 111,403; cpp: 52,727; sh: 27,784; makefile: 6,177; asm: 3,355; lex: 2,890; ada: 1,637; pascal: 1,621; xml: 1,221; yacc: 883; f90: 84; perl: 82; python: 33; fortran: 17; ruby: 13; sed: 12; php: 11
file content (154 lines) | stat: -rw-r--r-- 4,601 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
# 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.1.1 2004/04/02 22:35:05 joye Exp $
#

package require tcltest 2.1
namespace import -force tcltest::configure
namespace import -force tcltest::testsDirectory
configure -testdir [file join [pwd] [file dirname [info script]]]
configure -loadfile [file join [testsDirectory] constraints.tcl]
tcltest::loadTestedCommands

namespace import -force tcltest::makeDirectory

#----------------------------------------------------------------------
#
# Procedures needed by this test file
#
#----------------------------------------------------------------------

proc ToPressButton {parent btn} {
    after 100 SendButtonPress $parent $btn mouse
}

proc ToEnterDirsByKey {parent dirs} {
    after 100 [list EnterDirsByKey $parent $dirs]
}

proc PressButton {btn} {
    event generate $btn <Enter>
    event generate $btn <1> -x 5 -y 5
    event generate $btn <ButtonRelease-1> -x 5 -y 5
}

proc EnterDirsByKey {parent dirs} {
    global tk_strictMotif
    if {$parent == "."} {
	set w .__tk_choosedir
    } else {
	set w $parent.__tk_choosedir
    }
    upvar ::tk::dialog::file::__tk_choosedir data

    foreach dir $dirs {
	$data(ent) delete 0 end
	$data(ent) insert 0 $dir
	update
	SendButtonPress $parent ok mouse
	after 50
    }
}

proc SendButtonPress {parent btn type} {
    global tk_strictMotif
    if {$parent == "."} {
	set w .__tk_choosedir
    } else {
	set w $parent.__tk_choosedir
    }
    upvar ::tk::dialog::file::__tk_choosedir data

    set button $data($btn\Btn)
    if ![winfo ismapped $button] {
	update
    }

    if {$type == "mouse"} {
	PressButton $button
    } else {
	event generate $w <Enter>
	focus $w
	event generate $button <Enter>
	event generate $w <KeyPress> -keysym Return
    }
}


#----------------------------------------------------------------------
#
# The test suite proper
#
#----------------------------------------------------------------------
# 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" unixOnly {
	list [catch {tk_chooseDirectory $opt} msg] $msg
    } [list 1 "value for \"$opt\" missing"]
}
test choosedir-1.2 "tk_chooseDirectory command" unixOnly {
    list [catch {tk_chooseDirectory -foo bar} msg] $msg
} [list 1 "bad option \"-foo\": must be -initialdir, -mustexist, -parent, or -title"]
test choosedir-1.3 "tk_chooseDirectory command" unixOnly {
    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} {
    # first enter a bogus dirname, then enter a real one.
    ToEnterDirsByKey $parent [list $fake $real $real]
    set result [tk_chooseDirectory \
	    -title "Enter \"$fake\", press OK, enter \"$real\", press OK" \
	    -parent $parent -mustexist 1]
    set result
} $real
test choosedir-3.2 "tk_chooseDirectory -mustexist 0" {unixOnly} {
    ToEnterDirsByKey $parent [list $fake $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} {
    ToEnterDirsByKey $parent [list $fake $fake]
    tk_chooseDirectory \
	    -title "Enter \"$fake\" and press Ok" \
	    -parent $parent -initialdir $real
} $fake
test choosedir-4.3 "tk_chooseDirectory, -initialdir {}" {unixOnly} {
    catch {unset ::tk::dialog::file::__tk_choosedir}
    ToPressButton $parent ok
    tk_chooseDirectory \
	    -title "Press OK" \
	    -parent $parent -initialdir ""
} [pwd]

test choosedir-5.1 "tk_chooseDirectory, handles {} entry text" {unixOnly} {
    ToEnterDirsByKey $parent [list "" $real $real]
    tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \
	    -parent $parent
} $real

# cleanup
::tcltest::cleanupTests
return