summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog35
-rw-r--r--tests/choosedir.test84
-rw-r--r--tests/clipboard.test361
-rw-r--r--tests/embed.test98
-rw-r--r--tests/main.test138
5 files changed, 440 insertions, 276 deletions
diff --git a/ChangeLog b/ChangeLog
index d0264aa..230c23a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2008-08-12 Ania Pawelczyk <aniap@users.sourceforge.net>
+
+ * test/choosedir.test: Update to tcltest2
+ * test/clipboard.test:
+ * test/embed.test:
+ * test/main.test:
+
2008-08-12 Don Porter <dgp@users.sourceforge.net>
* README: Bump version number to 8.6a2
@@ -15,15 +22,15 @@
2008-08-11 Ania Pawelczyk <aniap@users.sourceforge.net>
* test/canvImg.test: Update to tcltest2
- * test/canvRect.test
- * test/canvText.test
- * test/obj.test
+ * test/canvRect.test:
+ * test/canvText.test:
+ * test/obj.test:
2008-08-07 Ania Pawelczyk <aniap@users.sourceforge.net>
* test/canvPs.test: Update to tcltest2
- * test/config.test
- * test/canvas.test
+ * test/config.test:
+ * test/canvas.test:
2008-08-05 Joe English <jenglish@users.sourceforge.net>
@@ -34,8 +41,8 @@
2008-08-03 Ania Pawelczyk <aniap@users.sourceforge.net>
* test/cmds.test: Update to tcltest2
- * test/dialog.test
- * test/get.test
+ * test/dialog.test:
+ * test/get.test:
* test/text.test: Update to tcltest2; report: 33.11 fails
2008-08-01 Pat Thoyts <patthoyts@users.sourceforge.net>
@@ -57,7 +64,7 @@
2008-07-28 Ania Pawelczyk <aniap@users.sourceforge.net>
* test/cursor.test: Update to tcltest2
- * test/message.test
+ * test/message.test:
2008-07-26 Pat Thoyts <patthoyts@users.sourceforge.net>
@@ -87,12 +94,12 @@
2008-07-22 Ania Pawelczyk <aniap@users.sourceforge.net>
* test/bell.test: Update to tcltest2
- * test/bgerror.test
- * test/bitmap.test
- * test/border.test
- * test/button.test
- * test/entry.test
- * test/spinbox.test
+ * test/bgerror.test:
+ * test/bitmap.test:
+ * test/border.test:
+ * test/button.test:
+ * test/entry.test:
+ * test/spinbox.test:
2008-07-22 Daniel Steffen <das@users.sourceforge.net>
diff --git a/tests/choosedir.test b/tests/choosedir.test
index 7d5d942..65cc4cb 100644
--- a/tests/choosedir.test
+++ b/tests/choosedir.test
@@ -5,10 +5,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: choosedir.test,v 1.15 2007/05/09 12:52:44 das Exp $
+# RCS: @(#) $Id: choosedir.test,v 1.16 2008/08/12 22:52:23 aniap Exp $
#
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
@@ -87,61 +88,86 @@ set fake [file join $dir non-existant]
set parent .
-foreach opt {-initialdir -mustexist -parent -title} {
- test choosedir-1.1$opt "tk_chooseDirectory command" unix {
- list [catch {tk_chooseDirectory $opt} msg] $msg
- } [list 1 "value for \"$opt\" missing"]
-}
-test choosedir-1.2 "tk_chooseDirectory command" unix {
- 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" unix {
- 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" {unix notAqua} {
+test choosedir-1.1 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -initialdir
+} -returnCodes error -result {value for "-initialdir" missing}
+test choosedir-1.2 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -mustexist
+} -returnCodes error -result {value for "-mustexist" missing}
+test choosedir-1.3 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -parent
+} -returnCodes error -result {value for "-parent" missing}
+test choosedir-1.4 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -title
+} -returnCodes error -result {value for "-title" missing}
+
+test choosedir-1.5 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -foo bar
+} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
+test choosedir-1.6 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -parent foo.bar
+} -returnCodes error -result {bad window path name "foo.bar"}
+
+
+test choosedir-2.1 {tk_chooseDirectory command, cancel gives null} -constraints {
+ unix notAqua
+} -body {
ToPressButton $parent cancel
tk_chooseDirectory -title "Press Cancel" -parent $parent
-} ""
+} -result {}
-test choosedir-3.1 "tk_chooseDirectory -mustexist 1" {unix notAqua} {
+
+test choosedir-3.1 {tk_chooseDirectory -mustexist 1} -constraints {
+ unix notAqua
+} -body {
# 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" {unix notAqua} {
+} -result $real
+test choosedir-3.2 {tk_chooseDirectory -mustexist 0} -constraints {
+ unix notAqua
+} -body {
ToEnterDirsByKey $parent [list $fake $fake]
tk_chooseDirectory -title "Enter \"$fake\", press OK" \
-parent $parent -mustexist 0
-} $fake
+} -result $fake
+
-test choosedir-4.1 "tk_chooseDirectory command, initialdir" {unix notAqua} {
+test choosedir-4.1 {tk_chooseDirectory command, initialdir} -constraints {
+ unix notAqua
+} -body {
ToPressButton $parent ok
tk_chooseDirectory -title "Press Ok" -parent $parent -initialdir $real
-} $real
-test choosedir-4.2 "tk_chooseDirectory command, initialdir" {unix notAqua} {
+} -result $real
+test choosedir-4.2 {tk_chooseDirectory command, initialdir} -constraints {
+ unix notAqua
+} -body {
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 {}" {unix notAqua} {
+} -result $fake
+test choosedir-4.3 {tk_chooseDirectory command, {} initialdir} -constraints {
+ unix notAqua
+} -body {
catch {unset ::tk::dialog::file::__tk_choosedir}
ToPressButton $parent ok
tk_chooseDirectory \
-title "Press OK" \
-parent $parent -initialdir ""
-} [pwd]
+} -result [pwd]
+
-test choosedir-5.1 "tk_chooseDirectory, handles {} entry text" {unix notAqua} {
+test choosedir-5.1 {tk_chooseDirectory, handles {} entry text} -constraints {
+ unix notAqua
+} -body {
ToEnterDirsByKey $parent [list "" $real $real]
tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \
-parent $parent
-} $real
+} -result $real
# cleanup
removeDirectory choosedirTest
diff --git a/tests/clipboard.test b/tests/clipboard.test
index 5248cc9..8c31971 100644
--- a/tests/clipboard.test
+++ b/tests/clipboard.test
@@ -6,14 +6,15 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: clipboard.test,v 1.10 2008/07/23 23:24:25 nijtmans Exp $
+# RCS: @(#) $Id: clipboard.test,v 1.11 2008/08/12 22:52:23 aniap Exp $
#
# Note: Multiple display clipboard handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
@@ -26,123 +27,188 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
# Now we start the main body of the test code
-test clipboard-1.1 {ClipboardHandler procedure} {
+test clipboard-1.1 {ClipboardHandler procedure} -setup {
clipboard clear
+} -body {
clipboard append "test"
clipboard get
-} {test}
-test clipboard-1.2 {ClipboardHandler procedure} {
+} -cleanup {
clipboard clear
+} -result {test}
+test clipboard-1.2 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
clipboard append "test"
clipboard append "ing"
clipboard get
-} {testing}
-test clipboard-1.3 {ClipboardHandler procedure} {
+} -cleanup {
+ clipboard clear
+} -result {testing}
+test clipboard-1.3 {ClipboardHandler procedure} -setup {
clipboard clear
+} -body {
clipboard append "t"
clipboard append "e"
clipboard append "s"
clipboard append "t"
clipboard get
-} {test}
-test clipboard-1.4 {ClipboardHandler procedure} {
+} -cleanup {
+ clipboard clear
+} -result {test}
+test clipboard-1.4 {ClipboardHandler procedure} -setup {
clipboard clear
+} -body {
clipboard append $longValue
clipboard get
-} "$longValue"
-test clipboard-1.5 {ClipboardHandler procedure} {
+} -cleanup {
clipboard clear
+} -result "$longValue"
+test clipboard-1.5 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
clipboard append $longValue
clipboard append "test"
clipboard get
-} "${longValue}test"
-test clipboard-1.6 {ClipboardHandler procedure} {
+} -cleanup {
+ clipboard clear
+} -result "${longValue}test"
+test clipboard-1.6 {ClipboardHandler procedure} -setup {
clipboard clear
+} -body {
clipboard append -t TEST $longValue
clipboard append -t STRING "test"
- list [clipboard get -t STRING] \
- [clipboard get -t TEST]
-} [list test $longValue]
-test clipboard-1.7 {ClipboardHandler procedure} {
+ list [clipboard get -t STRING] [clipboard get -t TEST]
+} -cleanup {
clipboard clear
+} -result [list test $longValue]
+test clipboard-1.7 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
clipboard append -t TEST [string range $longValue 1 4000]
clipboard append -t STRING "test"
- list [clipboard get -t STRING] \
- [clipboard get -t TEST]
-} [list test [string range $longValue 1 4000]]
-test clipboard-1.8 {ClipboardHandler procedure} {
+ list [clipboard get -t STRING] [clipboard get -t TEST]
+} -cleanup {
+ clipboard clear
+} -result [list test [string range $longValue 1 4000]]
+test clipboard-1.8 {ClipboardHandler procedure} -setup {
clipboard clear
+} -body {
clipboard append ""
clipboard get
-} {}
-test clipboard-1.9 {ClipboardHandler procedure} {
+} -cleanup {
clipboard clear
+} -result {}
+test clipboard-1.9 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
clipboard append ""
clipboard append "Test"
clipboard get
-} {Test}
+} -cleanup {
+ clipboard clear
+} -result {Test}
##############################################################################
-test clipboard-2.1 {ClipboardAppHandler procedure} {
+test clipboard-2.1 {ClipboardAppHandler procedure} -setup {
set oldAppName [tk appname]
- tk appname UnexpectedName
clipboard clear
+} -body {
+ tk appname UnexpectedName
clipboard append -type NEW_TYPE Data
- set result [selection get -selection CLIPBOARD -type TK_APPLICATION]
+ selection get -selection CLIPBOARD -type TK_APPLICATION
+} -cleanup {
tk appname $oldAppName
- set result
-} {UnexpectedName}
+ clipboard clear
+} -result {UnexpectedName}
##############################################################################
-test clipboard-3.1 {ClipboardWindowHandler procedure} {
+test clipboard-3.1 {ClipboardWindowHandler procedure} -setup {
set oldAppName [tk appname]
- tk appname UnexpectedName
clipboard clear
+} -body {
+ tk appname UnexpectedName
clipboard append -type NEW_TYPE Data
- set result [selection get -selection CLIPBOARD -type TK_WINDOW]
+ selection get -selection CLIPBOARD -type TK_WINDOW
+} -cleanup {
tk appname $oldAppName
- set result
-} {.}
+ clipboard clear
+} -result {.}
##############################################################################
-test clipboard-4.1 {ClipboardLostSel procedure} {
+test clipboard-4.1 {ClipboardLostSel procedure} -setup {
clipboard clear
+} -body {
clipboard append "Test"
selection clear -s CLIPBOARD
- list [catch {clipboard get} msg] $msg
-} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined}}
-test clipboard-4.2 {ClipboardLostSel procedure} {
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
+test clipboard-4.2 {ClipboardLostSel procedure} -setup {
clipboard clear
+} -body {
clipboard append "Test"
clipboard append -t TEST "Test2"
selection clear -s CLIPBOARD
- list [catch {clipboard get} msg] $msg \
- [catch {clipboard get -t TEST} msg] $msg
-} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined} 1 {CLIPBOARD selection doesn't exist or form "TEST" not defined}}
-test clipboard-4.3 {ClipboardLostSel procedure} {
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
+test clipboard-4.3 {ClipboardLostSel procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "Test"
+ clipboard append -t TEST "Test2"
+ selection clear -s CLIPBOARD
+ catch {clipboard get}
+ clipboard get -t TEST
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined}
+test clipboard-4.4 {ClipboardLostSel procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "Test"
+ clipboard append -t TEST "Test2"
+ clipboard append "Test3"
+ selection clear -s CLIPBOARD
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
+test clipboard-4.5 {ClipboardLostSel procedure} -setup {
clipboard clear
+} -body {
clipboard append "Test"
clipboard append -t TEST "Test2"
clipboard append "Test3"
selection clear -s CLIPBOARD
- list [catch {clipboard get} msg] $msg \
- [catch {clipboard get -t TEST} msg] $msg
-} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined} 1 {CLIPBOARD selection doesn't exist or form "TEST" not defined}}
+ catch {clipboard get}
+ clipboard get -t TEST
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined}
+
+
##############################################################################
-test clipboard-5.1 {Tk_ClipboardClear procedure} {
+test clipboard-5.1 {Tk_ClipboardClear procedure} -setup {
clipboard clear
+} -body {
clipboard append -t TEST "test"
set result [lsort [clipboard get TARGETS]]
clipboard clear
list $result [lsort [clipboard get TARGETS]]
-} {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test clipboard-5.2 {Tk_ClipboardClear procedure} {
+} -cleanup {
+ clipboard clear
+} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test clipboard-5.2 {Tk_ClipboardClear procedure} -setup {
clipboard clear
+} -body {
clipboard append -t TEST "test"
set result [lsort [clipboard get TARGETS]]
selection own -s CLIPBOARD .
@@ -150,97 +216,150 @@ test clipboard-5.2 {Tk_ClipboardClear procedure} {
clipboard clear
clipboard append -t TEST "test"
lappend result [lsort [clipboard get TARGETS]]
-} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+} -cleanup {
+ clipboard clear
+} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
##############################################################################
-test clipboard-6.1 {Tk_ClipboardAppend procedure} {
+test clipboard-6.1 {Tk_ClipboardAppend procedure} -setup {
clipboard clear
+} -body {
clipboard append "first chunk"
selection own -s CLIPBOARD .
- list [catch {
clipboard append " second chunk"
clipboard get
- } msg] $msg
-} {0 {first chunk second chunk}}
-test clipboard-6.2 {Tk_ClipboardAppend procedure} unix {
- setupbg
+} -cleanup {
clipboard clear
+} -returnCodes ok -result {first chunk second chunk}
+test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints unix -setup {
+ clipboard clear
+} -body {
+ setupbg
clipboard append -f INTEGER -t TEST "16"
set result [dobg {clipboard get TEST}]
+ return $result
+} -cleanup {
+ clipboard clear
cleanupbg
- set result
-} {0x10}
-test clipboard-6.3 {Tk_ClipboardAppend procedure} {
+} -result {0x10}
+test clipboard-6.3 {Tk_ClipboardAppend procedure} -setup {
clipboard clear
+} -body {
clipboard append -f INTEGER -t TEST "16"
- list [catch {clipboard append -t TEST "test"} msg] $msg
-} {1 {format "STRING" does not match current format "INTEGER" for TEST}}
+ clipboard append -t TEST "test"
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {format "STRING" does not match current format "INTEGER" for TEST}
##############################################################################
-test clipboard-7.1 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard} msg] $msg
-} {1 {wrong # args: should be "clipboard option ?arg ...?"}}
-test clipboard-7.2 {Tk_ClipboardCmd procedure} {
- clipboard clear
- list [catch {clipboard append --} msg] $msg \
- [selection get -selection CLIPBOARD]
-} {0 {} --}
-test clipboard-7.3 {Tk_ClipboardCmd procedure} {
- clipboard clear
- list [catch {clipboard append -- information} msg] $msg \
- [selection get -selection CLIPBOARD]
-} {0 {} information}
-test clipboard-7.4 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard append --x a b} msg] $msg
-} {1 {bad option "--x": must be -displayof, -format, or -type}}
-test clipboard-7.5 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard append -- a b} msg] $msg
-} {1 {wrong # args: should be "clipboard append ?-option value ...? data"}}
-test clipboard-7.6 {Tk_ClipboardCmd procedure} {
- clipboard clear
- list [catch {clipboard append -format} msg] $msg \
- [selection get -selection CLIPBOARD]
-} {0 {} -format}
-test clipboard-7.7 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard append -displayofoo f} msg] $msg
-} {1 {bad option "-displayofoo": must be -displayof, -format, or -type}}
-test clipboard-7.8 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard append -type TEST} msg] $msg
-} {1 {wrong # args: should be "clipboard append ?-option value ...? data"}}
-test clipboard-7.9 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard append -displayof foo "test"} msg] $msg
-} {1 {bad window path name "foo"}}
-
-test clipboard-7.10 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard clear -displayof} msg] $msg
-} {1 {wrong # args: should be "clipboard clear ?-displayof window?"}}
-test clipboard-7.11 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard clear -displayofoo f} msg] $msg
-} {1 {bad option "-displayofoo": must be -displayof}}
-test clipboard-7.12 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard clear foo} msg] $msg
-} {1 {wrong # args: should be "clipboard clear ?-displayof window?"}}
-test clipboard-7.13 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard clear -displayof foo} msg] $msg
-} {1 {bad window path name "foo"}}
-
-test clipboard-7.14 {Tk_ClipboardCmd procedure} {
- list [catch {clipboard error} msg] $msg
-} {1 {bad option "error": must be append, clear, or get}}
-
-test clipboard-7.15 {Tk_ClipboardCmd procedure} {
- clipboard clear
- list [catch {clipboard append -displayof} msg] $msg \
- [selection get -selection CLIPBOARD]
-} {0 {} -displayof}
-test clipboard-7.16 {Tk_ClipboardCmd procedure} {
- clipboard clear
- list [catch {clipboard append -type} msg] $msg \
- [selection get -selection CLIPBOARD]
-} {0 {} -type}
+test clipboard-7.1 {Tk_ClipboardCmd procedure} -body {
+ clipboard
+} -returnCodes error -result {wrong # args: should be "clipboard option ?arg ...?"}
+test clipboard-7.2 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append --
+} -cleanup {
+ clipboard clear
+} -returnCodes ok -result {}
+test clipboard-7.3 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append --
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {--}
+test clipboard-7.4 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -- information
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {information}
+test clipboard-7.5 {Tk_ClipboardCmd procedure} -body {
+ clipboard append --x a b
+} -returnCodes error -result {bad option "--x": must be -displayof, -format, or -type}
+test clipboard-7.6 {Tk_ClipboardCmd procedure} -body {
+ clipboard append -- a b
+} -returnCodes error -result {wrong # args: should be "clipboard append ?-option value ...? data"}
+test clipboard-7.7 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -format
+} -returnCodes ok -result {}
+test clipboard-7.8 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -format
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {-format}
+test clipboard-7.9 {Tk_ClipboardCmd procedure} -body {
+ clipboard append -displayofoo f
+} -returnCodes error -result {bad option "-displayofoo": must be -displayof, -format, or -type}
+test clipboard-7.10 {Tk_ClipboardCmd procedure} -body {
+ clipboard append -type TEST
+} -returnCodes error -result {wrong # args: should be "clipboard append ?-option value ...? data"}
+test clipboard-7.11 {Tk_ClipboardCmd procedure} -body {
+ clipboard append -displayof foo "test"
+} -returnCodes error -result {bad window path name "foo"}
+
+test clipboard-7.12 {Tk_ClipboardCmd procedure} -body {
+ clipboard clear -displayof
+} -returnCodes error -result {wrong # args: should be "clipboard clear ?-displayof window?"}
+test clipboard-7.13 {Tk_ClipboardCmd procedure} -body {
+ clipboard clear -displayofoo f
+} -returnCodes error -result {bad option "-displayofoo": must be -displayof}
+test clipboard-7.14 {Tk_ClipboardCmd procedure} -body {
+ clipboard clear foo
+} -returnCodes error -result {wrong # args: should be "clipboard clear ?-displayof window?"}
+test clipboard-7.15 {Tk_ClipboardCmd procedure} -body {
+ clipboard clear -displayof foo
+} -returnCodes error -result {bad window path name "foo"}
+
+test clipboard-7.16 {Tk_ClipboardCmd procedure} -body {
+ clipboard error
+} -returnCodes error -result {bad option "error": must be append, clear, or get}
+test clipboard-7.17 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -displayof
+} -cleanup {
+ clipboard clear
+} -returnCodes ok -result {}
+test clipboard-7.18 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -displayof
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {-displayof}
+test clipboard-7.19 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -type
+} -cleanup {
+ clipboard clear
+} -returnCodes ok -result {}
+test clipboard-7.20 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -type
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {-type}
# cleanup
cleanupTests
return
+
+
+
+
diff --git a/tests/embed.test b/tests/embed.test
index 6cf4854..db486f0 100644
--- a/tests/embed.test
+++ b/tests/embed.test
@@ -4,69 +4,87 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: embed.test,v 1.4 2005/02/15 03:22:10 chengyemao Exp $
+# RCS: @(#) $Id: embed.test,v 1.5 2008/08/12 22:52:23 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-global tcl_platform
-test embed-1.1 {TkpUseWindow procedure, bad window identifier} {
+test embed-1.1 {TkpUseWindow procedure, bad window identifier} -setup {
deleteWindows
- list [catch {toplevel .t -use xyz} msg] $msg
-} {1 {expected integer but got "xyz"}}
+} -body {
+ toplevel .t -use xyz
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "xyz"}
-test embed-1.2 {CreateFrame procedure, bad window identifier} {
+test embed-1.2 {CreateFrame procedure, bad window identifier} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -container xyz
+} -cleanup {
deleteWindows
- list [catch {toplevel .t -container xyz} msg] $msg
-} {1 {expected boolean value but got "xyz"}}
+} -returnCodes error -result {expected boolean value but got "xyz"}
-test embed-1.3 {CreateFrame procedure, both -use and
- -container is invalid } {
+test embed-1.3 {CreateFrame procedure, both -use and -container is invalid} -setup {
deleteWindows
+} -body {
toplevel .container -container 1
- list [catch {toplevel .t -use [winfo id .container] \
- -container 1} msg] $msg
-} {1 {A window cannot have both the -use and the -container option set.}}
-
-if {$tcl_platform(platform) == "windows"} {
-
-# testing window embedding for Windows platform
+ toplevel .t -use [winfo id .container] -container 1
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {A window cannot have both the -use and the -container option set.}
-test embed-1.4 {TkpUseWindow procedure, -container must be set} {
+# testing window embedding for win platforms
+test embed-1.4 {TkpUseWindow procedure, -container must be set} -constraints {
+ win
+} -setup {
deleteWindows
+} -body {
toplevel .container
- list [catch {toplevel .embd -use [winfo id .container]} err] $err
-} {1 {the window to use is not a Tk container}}
-
-test embed-1.5 {TkpUseWindow procedure, -container must be set} {
+ toplevel .embd -use [winfo id .container]
+} -cleanup {
deleteWindows
+} -returnCodes error -result {the window to use is not a Tk container}
+# testing window embedding for win platforms
+test embed-1.5 {TkpUseWindow procedure, -container must be set} -constraints {
+ win
+} -setup {
+ deleteWindows
+} -body {
frame .container
- list [catch {toplevel .embd -use [winfo id .container]} err] $err
-} {1 {the window to use is not a Tk container}}
-
-} else {
-
-# testing window embedding for other platforms
+ toplevel .embd -use [winfo id .container]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {the window to use is not a Tk container}
-test embed-1.4 {TkpUseWindow procedure, -container must be set} {
+# testing window embedding for other than win platforms
+test embed-1.5 {TkpUseWindow procedure, -container must be set} -constraints {
+ nonwin
+} -setup {
deleteWindows
+} -body {
toplevel .container
- list [catch {toplevel .embd -use [winfo id .container]} err] $err
-} {1 {window ".container" doesn't have -container option set}}
-
-test embed-1.5 {TkpUseWindow procedure, -container must be set} {
+ toplevel .embd -use [winfo id .container]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window ".container" doesn't have -container option set}
+# testing window embedding for other than win platforms
+test embed-1.6 {TkpUseWindow procedure, -container must be set} -constraints {
+ nonwin
+} -setup {
deleteWindows
+} -body {
frame .container
- list [catch {toplevel .embd -use [winfo id .container]} err] $err
-} {1 {window ".container" doesn't have -container option set}}
-
-}
+ toplevel .embd -use [winfo id .container]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window ".container" doesn't have -container option set}
-# FIXME: test cases common to unixEmbed.test and macEmbed.test should
-# be moved here.
cleanupTests
return
+
diff --git a/tests/main.test b/tests/main.test
index ede20f3..b7418e1 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -8,61 +8,57 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: main.test,v 1.11 2008/04/07 23:14:39 hobbs Exp $
+# RCS: @(#) $Id: main.test,v 1.12 2008/08/12 22:52:23 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test main-1.1 {StdinProc} -constraints stdio -setup {
- set script [makeFile {
- close stdin; exit
- } script]
+ set script [makeFile {close stdin; exit} script]
} -body {
- list [catch {exec [interpreter] <$script} msg] $msg
+ exec [interpreter] <$script
} -cleanup {
removeFile script
-} -result {0 {}}
+} -returnCodes ok
-test main-2.1 {Tk_MainEx: -encoding option} -constraints {
- stdio
- } -setup {
- set script [makeFile {} script]
- file delete $script
- set f [open $script w]
- fconfigure $f -encoding utf-8
- puts $f {puts [list $argv0 $argv $tcl_interactive]}
- puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]; exit"
- close $f
- catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]}
- } -body {
- read $f
- } -cleanup {
- close $f
- removeFile script
- } -result [list script {} 0]\n1\n
+test main-2.1 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]; exit"
+ close $f
+ catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]}
+} -body {
+ read $f
+} -cleanup {
+ close $f
+ removeFile script
+} -result "script {} 0\n1\n"
-test main-2.2 {Tk_MainEx: -encoding option} -constraints {
- stdio
- } -setup {
- set script [makeFile {} script]
- file delete $script
- set f [open $script w]
- fconfigure $f -encoding utf-8
- puts $f {puts [list $argv0 $argv $tcl_interactive]}
- puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]; exit"
- close $f
- catch {set f [open "|[list [interpreter] -encoding ascii script]" r]}
- } -body {
- read $f
- } -cleanup {
- close $f
- removeFile script
- } -result [list script {} 0]\n0\n
+test main-2.2 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]; exit"
+ close $f
+ catch {set f [open "|[list [interpreter] -encoding ascii script]" r]}
+} -body {
+ read $f
+} -cleanup {
+ close $f
+ removeFile script
+} -result "script {} 0\n0\n"
- # Procedure to simulate interactive typing of commands, line by line
+ # Procedure to simulate interactive typing of commands, line by line,
+ # for test 2.3
proc type {chan script} {
foreach line [split $script \n] {
if {[catch {
@@ -76,52 +72,50 @@ test main-2.2 {Tk_MainEx: -encoding option} -constraints {
}
}
-test main-2.3 {Tk_MainEx: -encoding option} -constraints {
- stdio
- } -setup {
- set script [makeFile {} script]
- file delete $script
- set f [open $script w]
- fconfigure $f -encoding utf-8
- puts $f {puts [list $argv0 $argv $tcl_interactive]}
- puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]"
- close $f
- catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]}
- } -body {
- type $f {
- puts $argv
- exit
- }
- list [catch {gets $f} line] $line
- } -cleanup {
- close $f
- removeFile script
- } -result {0 {-enc utf-8 script}}
+test main-2.3 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]"
+ close $f
+ catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]}
+} -body {
+ type $f {
+ puts $argv
+ exit
+ }
+ gets $f
+} -cleanup {
+ close $f
+ removeFile script
+} -returnCodes ok -result {-enc utf-8 script}
test main-3.1 {Tk_ParseArgv: -help option} -constraints unix -body {
# Run only on unix as Win32 pops up native dialog
- list [catch {exec [interpreter] -help} msg] $msg
-} -match glob -result {1 {% Application initialization failed: Command-specific options:*}}
+ exec [interpreter] -help
+} -returnCodes error -match glob -result {% Application initialization failed: Command-specific options:*}
test main-3.2 {Tk_ParseArgv: -help option} -setup {
set maininterp [interp create]
} -body {
$maininterp eval { set argc 1 ; set argv -help }
- list [catch {load {} Tk $maininterp} msg] $msg
+ load {} Tk $maininterp
} -cleanup {
interp delete $maininterp
-} -match glob -result {1 {Command-specific options:*}}
+} -returnCodes error -match glob -result {Command-specific options:*}
test main-3.3 {Tk_ParseArgv: -help option} -setup {
set maininterp [interp create]
} -body {
# Repeat of 3.2 to catch cleanup, eg Bug 1927135
$maininterp eval { set argc 1 ; set argv -help }
- list [catch {load {} Tk $maininterp} msg] $msg
+ load {} Tk $maininterp
} -cleanup {
interp delete $maininterp
-} -match glob -result {1 {Command-specific options:*}}
+} -returnCodes error -match glob -result {Command-specific options:*}
# cleanup
cleanupTests