OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [tags/] [start/] [insight/] [tk/] [tests/] [filebox.test] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# This file is a Tcl script to test out Tk's "tk_getOpenFile" and
2 
# "tk_getSaveFile" commands. It is organized in the standard fashion
3 
# for Tcl tests.
4 
#
5 
# Copyright (c) 1996 Sun Microsystems, Inc.
6 
#
7 
# See the file "license.terms" for information on usage and redistribution
8 
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
9 
#
10 
# RCS: @(#) $Id: filebox.test,v 1.1.1.1 2002-01-16 10:25:58 markom Exp $
11 
#
12 
 
13 
set tk_strictMotif_old $tk_strictMotif
14 
 
15 
#----------------------------------------------------------------------
16 
#
17 
# Procedures needed by this test file
18 
#
19 
#----------------------------------------------------------------------
20 
 
21 
proc ToPressButton {parent btn} {
22 
    global isNative
23 
    if {!$isNative} {
24 
        after 100 SendButtonPress $parent $btn mouse
25 
    }
26 
}
27 
 
28 
proc ToEnterFileByKey {parent fileName fileDir} {
29 
    global isNative
30 
    if {!$isNative} {
31 
        after 100 EnterFileByKey $parent [list $fileName] [list $fileDir]
32 
    }
33 
}
34 
 
35 
proc PressButton {btn} {
36 
    event generate $btn
37 
    event generate $btn <1> -x 5 -y 5
38 
    event generate $btn  -x 5 -y 5
39 
}
40 
 
41 
proc EnterFileByKey {parent fileName fileDir} {
42 
    global tk_strictMotif
43 
    if {$parent == "."} {
44 
        set w .__tk_filedialog
45 
    } else {
46 
        set w $parent.__tk_filedialog
47 
    }
48 
    upvar #0 [winfo name $w] data
49 
 
50 
    if {$tk_strictMotif} {
51 
        $data(sEnt) delete 0 end
52 
        $data(sEnt) insert 0 [file join $fileDir $fileName]
53 
    } else {
54 
        $data(ent) delete 0 end
55 
        $data(ent) insert 0 $fileName
56 
    }
57 
 
58 
    update
59 
    SendButtonPress $parent ok mouse
60 
}
61 
 
62 
proc SendButtonPress {parent btn type} {
63 
    global tk_strictMotif
64 
    if {$parent == "."} {
65 
        set w .__tk_filedialog
66 
    } else {
67 
        set w $parent.__tk_filedialog
68 
    }
69 
    upvar #0 [winfo name $w] data
70 
 
71 
    set button $data($btn\Btn)
72 
    if ![winfo ismapped $button] {
73 
        update
74 
    }
75 
 
76 
    if {$type == "mouse"} {
77 
        PressButton $button
78 
    } else {
79 
        event generate $w
80 
        focus $w
81 
        event generate $button
82 
        event generate $w  -keysym Return
83 
    }
84 
}
85 
 
86 
 
87 
#----------------------------------------------------------------------
88 
#
89 
# The test suite proper
90 
#
91 
#----------------------------------------------------------------------
92 
 
93 
if {[string compare test [info procs test]] == 1} {
94 
    source defs
95 
}
96 
 
97 
if {$tcl_platform(platform) == "unix"} {
98 
    set modes "0 1"
99 
} else {
100 
    set modes 1
101 
}
102 
 
103 
foreach mode $modes {
104 
 
105 
    #
106 
    # Test both the motif version and the "tk" version of the file dialog
107 
    # box on Unix.
108 
    #
109 
 
110 
    if {$tcl_platform(platform) == "unix"} {
111 
        set tk_strictMotif $mode
112 
    }
113 
 
114 
    #
115 
    # Test both the "open" and the "save" dialogs
116 
    #
117 
 
118 
    foreach command "tk_getOpenFile tk_getSaveFile" {
119 
 
120 
        if {$command == "tk_getOpenFile" && $mode == 0} {
121 
            set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent or -title}}
122 
        } else {
123 
            set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent or -title}}
124 
        }
125 
 
126 
        test filebox-1.1 "$command command" {
127 
            list [catch {$command -foo} msg] $msg
128 
        } $unknownOptionsMsg
129 
 
130 
        regsub -all ,      $msg "" options
131 
        regsub \"-foo\" $options "" options
132 
 
133 
        foreach option $options {
134 
            if {[string index $option 0] == "-"} {
135 
                test filebox-1.2 "$command command" {
136 
                    list [catch {$command $option} msg] $msg
137 
                } [list 1 "value for \"$option\" missing"]
138 
            }
139 
        }
140 
 
141 
        test filebox-1.3 "$command command" {
142 
            list [catch {$command -foo bar} msg] $msg
143 
        } $unknownOptionsMsg
144 
 
145 
        test filebox-1.4 "$command command" {
146 
            list [catch {$command -initialdir} msg] $msg
147 
        } {1 {value for "-initialdir" missing}}
148 
 
149 
        test filebox-1.5 "$command command" {
150 
            list [catch {$command -parent foo.bar} msg] $msg
151 
        } {1 {bad window path name "foo.bar"}}
152 
 
153 
        test filebox-1.6 "$command command" {
154 
            list [catch {$command -filetypes {Foo}} msg] $msg
155 
        } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}}
156 
 
157 
        if {[info commands tkMotifFDialog] == "" && [info commands tkFDialog] == ""} {
158 
            set isNative 1
159 
        } else {
160 
            set isNative 0
161 
        }
162 
 
163 
        if {$isNative && ![info exists INTERACTIVE]} {
164 
            continue
165 
        }
166 
 
167 
        set parent .
168 
 
169 
        set verylongstring longstring:
170 
        set verylongstring $verylongstring$verylongstring
171 
        set verylongstring $verylongstring$verylongstring
172 
        set verylongstring $verylongstring$verylongstring
173 
        set verylongstring $verylongstring$verylongstring
174 
#       set verylongstring $verylongstring$verylongstring
175 
#       set verylongstring $verylongstring$verylongstring
176 
#       set verylongstring $verylongstring$verylongstring
177 
#       set verylongstring $verylongstring$verylongstring
178 
#       set verylongstring $verylongstring$verylongstring
179 
 
180 
        set color #404040
181 
        test filebox-2.1 "$command command" {
182 
            ToPressButton $parent cancel
183 
            $command -title "Press Cancel ($verylongstring)" -parent $parent
184 
        } ""
185 
 
186 
 
187 
        if {$command == "tk_getSaveFile"} {
188 
            set fileName "12x 455"
189 
            set fileDir [pwd]
190 
            set pathName [file join [pwd] $fileName]
191 
        } else {
192 
            set thisFile [info script]
193 
            set fileName [file tail $thisFile]
194 
            set appPWD [pwd]
195 
            cd [file dirname $thisFile]
196 
            set fileDir [pwd]
197 
            cd $appPWD
198 
            set pathName [file join $fileDir $fileName]
199 
        }
200 
 
201 
        test filebox-2.2 "$command command" {
202 
            ToPressButton $parent ok
203 
            set choice [$command -title "Press Ok" \
204 
                            -parent $parent -initialfile $fileName -initialdir $fileDir]
205 
        } $pathName
206 
 
207 
        test filebox-2.3 "$command command" {
208 
            ToEnterFileByKey $parent $fileName $fileDir
209 
            set choice [$command -title "Enter \"$fileName\" and press Ok" \
210 
                            -parent $parent -initialdir $fileDir]
211 
        } $pathName
212 
 
213 
        test filebox-2.4 "$command command" {
214 
            ToPressButton $parent ok
215 
            set choice [$command -title "Enter \"$fileName\" and press Ok" \
216 
                            -parent $parent -initialdir . \
217 
                            -initialfile $fileName]
218 
        } $pathName
219 
 
220 
        test filebox-2.5 "$command command" {
221 
            ToPressButton $parent ok
222 
            set choice [$command -title "Enter \"$fileName\" and press Ok" \
223 
                            -parent $parent -initialdir /badpath \
224 
                            -initialfile $fileName]
225 
        } $pathName
226 
 
227 
        test filebox-2.6 "$command command" {
228 
            toplevel .t1; toplevel .t2
229 
            ToPressButton .t1 ok
230 
            set choice {}
231 
            lappend choice [$command \
232 
                    -title "Enter \"$fileName\" and press Ok" \
233 
                    -parent .t1 -initialdir $fileDir \
234 
                    -initialfile $fileName]
235 
            ToPressButton .t2 ok
236 
            lappend choice [$command \
237 
                    -title "Enter \"$fileName\" and press Ok" \
238 
                    -parent .t2 -initialdir $fileDir \
239 
                    -initialfile $fileName]
240 
            ToPressButton .t1 ok
241 
            lappend choice [$command \
242 
                    -title "Enter \"$fileName\" and press Ok" \
243 
                    -parent .t1 -initialdir $fileDir \
244 
                    -initialfile $fileName]
245 
            destroy .t1
246 
            destroy .t2
247 
            set choice
248 
        } [list $pathName $pathName $pathName]
249 
 
250 
 
251 
 
252 
        set filters(1) {}
253 
 
254 
        set filters(2) {
255 
            {"Text files"       {.txt .doc}     }
256 
            {"Text files"       {}              TEXT}
257 
            {"Tcl Scripts"      {.tcl}          TEXT}
258 
            {"C Source Files"   {.c .h}         }
259 
            {"All Source Files" {.tcl .c .h}    }
260 
            {"Image Files"      {.gif}          }
261 
            {"Image Files"      {.jpeg .jpg}    }
262 
            {"Image Files"      ""              {GIFF JPEG}}
263 
            {"All files"        *}
264 
        }
265 
 
266 
        set filters(3) {
267 
            {"Text files"       {.txt .doc}     TEXT}
268 
            {"Foo"              {""}            TEXT}
269 
        }
270 
 
271 
        foreach x [lsort -integer [array names filters]] {
272 
            test filebox-3.$x "$command command" {
273 
                ToPressButton $parent ok
274 
                set choice [$command -title "Press Ok" -filetypes $filters($x)\
275 
                                -parent $parent -initialfile $fileName -initialdir $fileDir]
276 
            } $pathName
277 
        }
278 
 
279 
        #
280 
        # The rest of the tests need to be executed on Unix only. The test whether
281 
        # the dialog box widgets were implemented correctly. These tests are not
282 
        # needed on the other platforms because they use native file dialogs.
283 
        #
284 
 
285 
 
286 
 
287 
 
288 
        # end inner if
289 
    }
290 
 
291 
    # end outer if
292 
}
293 
 
294 
set tk_strictMotif $tk_strictMotif_old
295 
 
296 
if {$isNative && ![info exists INTERACTIVE]} {
297 
    puts " Some tests were skipped because they could not be performed"
298 
    puts " automatically on this platform. If you wish to execute them"
299 
    puts " interactively, set the TCL variable INTERACTIVE and re-run"
300 
    puts " the test."
301 
    return
302 
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.