summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog9
-rw-r--r--library/tkfbox.tcl9
-rw-r--r--tests/filebox.test65
3 files changed, 78 insertions, 5 deletions
diff --git a/ChangeLog b/ChangeLog
index 5fd055c..cf57bd5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2007-11-26 Kevin Kenny <kennykb@acm.org>
+
+ * library/tkfbox.tcl (VerifyFileName): Corrected a couple
+ of typos in handling of bad file names. [Bug #1822076]
+ * tests/filebox.test (filebox-7.1, filebox-7.2): Added
+ test cases that exercise the above bug.
+ Thanks to Christoph Bauer (fridolin@users.sf.net) for the
+ patch.
+
2007-11-25 Joe English <jenglish@users.sourceforge.net>
* generic/ttk/ttkManager.h, generic/ttk/ttkManager.c,
diff --git a/library/tkfbox.tcl b/library/tkfbox.tcl
index 51c7d9c..82f4075 100644
--- a/library/tkfbox.tcl
+++ b/library/tkfbox.tcl
@@ -11,7 +11,7 @@
# files by clicking on the file icons or by entering a filename
# in the "Filename:" entry.
#
-# RCS: @(#) $Id: tkfbox.tcl,v 1.66 2007/11/21 16:29:08 dkf Exp $
+# RCS: @(#) $Id: tkfbox.tcl,v 1.67 2007/11/26 20:00:52 kennykb Exp $
#
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
@@ -1682,13 +1682,14 @@ proc ::tk::dialog::file::VerifyFileName {w filename} {
$data(ent) icursor end
}
CHDIR {
- tk_messageBox -type ok -parent $w -message -icon warning \
- [mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $path]
+ tk_messageBox -type ok -parent $w -icon warning -message \
+ [mc "Cannot change to the directory\
+ \"%1\$s\".\nPermission denied." $path]
$data(ent) selection range 0 end
$data(ent) icursor end
}
ERROR {
- tk_messageBox -type ok -parent $w -message -icon warning \
+ tk_messageBox -type ok -parent $w -icon warning -message \
[mc "Invalid file name \"%1\$s\"." $path]
$data(ent) selection range 0 end
$data(ent) icursor end
diff --git a/tests/filebox.test b/tests/filebox.test
index 9e9fe11..a99f99c 100644
--- a/tests/filebox.test
+++ b/tests/filebox.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: filebox.test,v 1.19 2007/10/25 21:44:23 hobbs Exp $
+# RCS: @(#) $Id: filebox.test,v 1.20 2007/11/26 20:00:53 kennykb Exp $
#
package require tcltest 2.1
@@ -401,6 +401,69 @@ foreach mode $modes {
} $pathName[lindex $addedExtensions $x]
}
+ if {!$mode} {
+
+ test filebox-7.1-$mode "tk_getOpenFile - directory not readable" \
+ -constraints nonUnixUserInteraction \
+ -setup {
+ rename ::tk_messageBox ::saved_messageBox
+ set ::gotmessage {}
+ proc tk_messageBox args {
+ set ::gotmessage $args
+ }
+ toplevel .t1
+ file mkdir [file join $fileDir NOTREADABLE]
+ file attributes [file join $fileDir NOTREADABLE] \
+ -permissions 300
+ } \
+ -cleanup {
+ rename ::tk_messageBox {}
+ rename ::saved_messageBox ::tk_messageBox
+ unset ::gotmessage
+ destroy .t1
+ file delete -force [file join $fileDir NOTREADABLE]
+ } \
+ -body {
+ ToEnterFileByKey .t1 NOTREADABLE $fileDir
+ ToPressButton .t1 ok
+ ToPressButton .t1 cancel
+ tk_getOpenFile -parent .t1 \
+ -title "Please select the NOTREADABLE directory" \
+ -initialdir $fileDir
+ set gotmessage
+ } \
+ -match glob \
+ -result "*NOTREADABLE*"
+
+ test filebox-7.2-$mode "tk_getOpenFile - bad file name" \
+ -constraints nonUnixUserInteraction \
+ -setup {
+ rename ::tk_messageBox ::saved_messageBox
+ set ::gotmessage {}
+ proc tk_messageBox args {
+ set ::gotmessage $args
+ }
+ toplevel .t1
+ } \
+ -cleanup {
+ rename ::tk_messageBox {}
+ rename ::saved_messageBox ::tk_messageBox
+ unset ::gotmessage
+ destroy .t1
+ } \
+ -body {
+ ToEnterFileByKey .t1 RUBBISH $fileDir
+ ToPressButton .t1 ok
+ ToPressButton .t1 cancel
+ tk_getOpenFile -parent .t1 \
+ -title "Please enter RUBBISH as a file name" \
+ -initialdir $fileDir
+ set gotmessage
+ } \
+ -match glob \
+ -result "*RUBBISH*"
+ }
+
# 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