archie/tk4.2/tests/filebox.test

252 lines
6.4 KiB
Plaintext
Raw Permalink Normal View History

2024-05-27 16:40:40 +02:00
# This file is a Tcl script to test out Tk's "tk_getOpenFile" and
# "tk_getSaveFile" commands. It is organized in the standard fashion
# for Tcl tests.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) filebox.test 1.3 96/09/26 09:17:12
#
set tk_strictMotif_old $tk_strictMotif
#----------------------------------------------------------------------
#
# Procedures needed by this test file
#
#----------------------------------------------------------------------
proc ToPressButton {parent btn} {
global isNative
if {!$isNative} {
after 100 SendButtonPress $parent $btn mouse
}
}
proc ToEnterFileByKey {parent fileName fileDir} {
global isNative
if {!$isNative} {
after 100 EnterFileByKey $parent [list $fileName] [list $fileDir]
}
}
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 EnterFileByKey {parent fileName fileDir} {
global tk_strictMotif
set w .__tk_filedialog
upvar #0 $w data
if {$tk_strictMotif} {
$data(sEnt) delete 0 end
$data(sEnt) insert 0 [file join $fileDir $fileName]
} else {
$data(ent) delete 0 end
$data(ent) insert 0 $fileName
}
update
SendButtonPress $parent ok mouse
}
proc SendButtonPress {parent btn type} {
global tk_strictMotif
set w .__tk_filedialog
upvar #0 $w 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
#
#----------------------------------------------------------------------
if {[string compare test [info procs test]] == 1} {
source defs
}
if {$tcl_platform(platform) == "unix"} {
set modes "0 1"
} else {
set modes 1
}
set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent or -title}}
foreach mode $modes {
#
# Test both the motif version and the "tk" version of the file dialog
# box on Unix.
#
if {$tcl_platform(platform) == "unix"} {
set tk_strictMotif $mode
}
#
# Test both the "open" and the "save" dialogs
#
foreach command "tk_getOpenFile tk_getSaveFile" {
test filebox-1.1 "$command command" {
list [catch {$command -foo} msg] $msg
} $unknownOptionsMsg
regsub -all , $msg "" options
regsub \"-foo\" $options "" options
foreach option $options {
if {[string index $option 0] == "-"} {
test filebox-1.2 "$command command" {
list [catch {$command $option} msg] $msg
} [list 1 "value for \"$option\" missing"]
}
}
test filebox-1.3 "$command command" {
list [catch {$command -foo bar} msg] $msg
} $unknownOptionsMsg
test filebox-1.4 "$command command" {
list [catch {$command -initialdir} msg] $msg
} {1 {value for "-initialdir" missing}}
test filebox-1.5 "$command command" {
list [catch {$command -parent foo.bar} msg] $msg
} {1 {bad window path name "foo.bar"}}
test filebox-1.6 "$command command" {
list [catch {$command -filetypes {Foo}} msg] $msg
} {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}}
if {[info commands tkMotifFDialog] == "" && [info commands tkFDialog] == ""} {
set isNative 1
} else {
set isNative 0
}
if {$isNative && ![info exists INTERACTIVE]} {
continue
}
set parent .
set verylongstring longstring:
set verylongstring $verylongstring$verylongstring
set verylongstring $verylongstring$verylongstring
set verylongstring $verylongstring$verylongstring
set verylongstring $verylongstring$verylongstring
# set verylongstring $verylongstring$verylongstring
# set verylongstring $verylongstring$verylongstring
# set verylongstring $verylongstring$verylongstring
# set verylongstring $verylongstring$verylongstring
# set verylongstring $verylongstring$verylongstring
set color #404040
test filebox-2.1 "$command command" {
ToPressButton $parent cancel
$command -title "Press Cancel ($verylongstring)" -parent $parent
} ""
if {$command == "tk_getSaveFile"} {
set fileName "12x 455"
set fileDir [pwd]
set pathName [file join [pwd] $fileName]
} else {
set thisFile [info script]
set fileName [file tail $thisFile]
set appPWD [pwd]
cd [file dirname $thisFile]
set fileDir [pwd]
cd $appPWD
set pathName [file join $fileDir $fileName]
}
test filebox-2.2 "$command command" {
ToPressButton $parent ok
set choice [$command -title "Press Ok" \
-parent $parent -initialfile $fileName -initialdir $fileDir]
} $pathName
test filebox-2.3 "$command command" {
ToEnterFileByKey $parent $fileName $fileDir
set choice [$command -title "Enter \"$fileName\" and press Ok" \
-parent $parent -initialdir $fileDir]
} $pathName
set filters(1) {}
set filters(2) {
{"Text files" {.txt .doc} }
{"Text files" {} TEXT}
{"Tcl Scripts" {.tcl} TEXT}
{"C Source Files" {.c .h} }
{"All Source Files" {.tcl .c .h} }
{"Image Files" {.gif} }
{"Image Files" {.jpeg .jpg} }
{"Image Files" "" {GIFF JPEG}}
{"All files" *}
}
set filters(3) {
{"Text files" {.txt .doc} TEXT}
{"Foo" {""} TEXT}
}
foreach x [lsort -integer [array names filters]] {
test filebox-3.$x "$command command" {
ToPressButton $parent ok
set choice [$command -title "Press Ok" -filetypes $filters($x)\
-parent $parent -initialfile $fileName -initialdir $fileDir]
} $pathName
}
#
# The rest of the tests need to be executed on Unix only. The test whether
# the dialog box widgets were implemented correctly. These tests are not
# needed on the other platforms because they use native file dialogs.
#
# end inner if
}
# end outer if
}
set tk_strictMotif $tk_strictMotif_old
if {$isNative && ![info exists INTERACTIVE]} {
puts " Some tests were skipped because they could not be performed"
puts " automatically on this platform. If you wish to execute them"
puts " interactively, set the TCL variable INTERACTIVE and re-run"
puts " the test."
return
}