summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/fileName.test9
-rw-r--r--tests/stringObj.test13
-rw-r--r--tests/trace.test159
3 files changed, 175 insertions, 6 deletions
diff --git a/tests/fileName.test b/tests/fileName.test
index d9dd9d4..580ec90 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: fileName.test,v 1.26 2002/07/10 13:08:20 dkf Exp $
+# RCS: @(#) $Id: fileName.test,v 1.27 2002/11/13 22:11:41 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1816,6 +1816,13 @@ test filename-16.16 {windows specific globbing} {pcOnly} {
file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
} {..}
+test filename-17.1 {windows specific special files} {testsetplatform} {
+ testsetplatform win
+ list [file pathtype com1] [file pathtype con] [file pathtype lpt3] \
+ [file pathtype prn] [file pathtype nul] [file pathtype aux] \
+ [file pathtype foo]
+} {absolute absolute absolute absolute absolute absolute relative}
+
# cleanup
catch {file delete -force C:/globTest}
file delete -force globTest
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 115ba2c..c2db812 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: stringObj.test,v 1.11 2000/06/28 18:11:21 ericm Exp $
+# RCS: @(#) $Id: stringObj.test,v 1.12 2002/11/13 22:11:41 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -415,6 +415,17 @@ test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} {
list [string length $a] [string length $a]
} {10 10}
+test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} {knownBug} {
+ teststringobj set 1 foo
+ teststringobj getunicode 1
+ teststringobj append 1 bar -1
+ teststringobj getunicode 1
+ teststringobj append 1 bar -1
+ teststringobj setlength 1 0
+ teststringobj append 1 bar -1
+ teststringobj get 1
+} {bar}
+
testobj freeallvars
# cleanup
diff --git a/tests/trace.test b/tests/trace.test
index f72b0bd..2e8b61b 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: trace.test,v 1.23 2002/10/15 16:13:47 vincentdarley Exp $
+# RCS: @(#) $Id: trace.test,v 1.24 2002/11/13 22:11:41 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1850,24 +1850,175 @@ test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)}
trace add execution foo {enter enterstep leavestep leave} \
[list traceExecute foo]
update
- after idle {puts idle}
+ after idle {set a "idle"}
foo
trace remove execution foo {enter enterstep leavestep leave} \
[list traceExecute foo]
rename foo {}
+ catch {unset a}
join $info "\n"
} {foo foo enter
foo {set a 1} enterstep
foo {set a 1} 0 1 leavestep
foo {update idletasks} enterstep
-foo {puts idle} enterstep
-foo {puts idle} 0 {} leavestep
+foo {set a idle} enterstep
+foo {set a idle} 0 idle leavestep
foo {update idletasks} 0 {} leavestep
foo {set b 1} enterstep
foo {set b 1} 0 1 leavestep
foo foo 0 1 leave}
+test trace-28.2 {exec traces with 'error'} {
+ set info {}
+ set res {}
+
+ proc foo {} {
+ if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }
+ }
+
+ proc bar {} { error "msg" }
+
+ lappend res [foo]
+
+ trace add execution foo {enter enterstep leave leavestep} \
+ [list traceExecute foo]
+
+ # With the trace active
+
+ lappend res [foo]
+
+ trace remove execution foo {enter enterstep leave leavestep} \
+ [list traceExecute foo]
+
+ list $res [join $info \n]
+} {{error error} {foo foo enter
+foo {if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }} enterstep
+foo {catch bar} enterstep
+foo bar enterstep
+foo {error msg} enterstep
+foo {error msg} 1 msg leavestep
+foo bar 1 msg leavestep
+foo {catch bar} 0 1 leavestep
+foo {return error} enterstep
+foo {return error} 2 error leavestep
+foo {if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }} 2 error leavestep
+foo foo 0 error leave}}
+
+test trace-28.3 {exec traces with 'return -code error'} {
+ set info {}
+ set res {}
+
+ proc foo {} {
+ if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }
+ }
+
+ proc bar {} { return -code error "msg" }
+
+ lappend res [foo]
+
+ trace add execution foo {enter enterstep leave leavestep} \
+ [list traceExecute foo]
+
+ # With the trace active
+
+ lappend res [foo]
+
+ trace remove execution foo {enter enterstep leave leavestep} \
+ [list traceExecute foo]
+
+ list $res [join $info \n]
+} {{error error} {foo foo enter
+foo {if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }} enterstep
+foo {catch bar} enterstep
+foo bar enterstep
+foo {return -code error msg} enterstep
+foo {return -code error msg} 2 msg leavestep
+foo bar 1 msg leavestep
+foo {catch bar} 0 1 leavestep
+foo {return error} enterstep
+foo {return error} 2 error leavestep
+foo {if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }} 2 error leavestep
+foo foo 0 error leave}}
+
+test trace-28.4 {exec traces in slave with 'return -code error'} {knownBug} {
+ interp create slave
+ interp alias slave traceExecute {} traceExecute
+ set res [interp eval slave {
+ set info {}
+ set res {}
+
+ proc foo {} {
+ if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }
+ }
+
+ proc bar {} { return -code error "msg" }
+
+ lappend res [foo]
+
+ trace add execution foo {enter enterstep leave leavestep} \
+ [list traceExecute foo]
+
+ # With the trace active
+
+ lappend res [foo]
+
+ trace remove execution foo {enter enterstep leave leavestep} \
+ [list traceExecute foo]
+
+ list $res [join $info \n]
+ }]
+ interp delete slave
+ set res
+} {{error error} {foo foo enter
+foo {if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }} enterstep
+foo {catch bar} enterstep
+foo bar enterstep
+foo {return -code error msg} enterstep
+foo {return -code error msg} 2 msg leavestep
+foo bar 1 msg leavestep
+foo {catch bar} 0 1 leavestep
+foo {return error} enterstep
+foo {return error} 2 error leavestep
+foo {if {[catch {bar}]} {
+ return "error"
+ } else {
+ return "ok"
+ }} 2 error leavestep
+foo foo 0 error leave}}
+
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}