* tests/async.test: Added several tests that demonstrate Tcl

        * tests/basic.test:     Bug 489537, Tcl's longstanding failure to
        * tests/dict.test:      properly quote any leading '#' character
        * tests/dstring.test:   when generating the string rep of a list
        * tests/list.test:      so that the comment-power of that character
        * tests/parse.test:     is hidden from any [eval], in order to
        * tests/util.test:      satisfy the documentation that [list] does
        [eval]-safe quoting.


FossilOrigin-Name: 03d3df98ff7cdfa4ebd84d70cf3d5ecb99bab3c5

7 files changed, 148 insertions, 12 deletions

diff --git a/tests/async.test b/tests/async.test
index 307a707..af63413 100644
--- a/tests/async.test
+++ b/tests/async.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: async.test,v 1.5 2000/04/10 17:18:56 ericm Exp $
+# RCS: @(#) $Id: async.test,v 1.6 2003/07/24 16:05:24 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -42,10 +42,17 @@ proc async3 {result code} {
     set aresult "test pattern"
     return -code $code $result
 }
+proc \# {result code} {
+    global aresult acode
+    set aresult $result
+    set acode $code
+    return "comment quoting"
+}
 
 set handler1 [testasync create async1]
 set handler2 [testasync create async2]
 set handler3 [testasync create async3]
+set handler4 [testasync create #]
 test async-1.1 {basic async handlers} {
     set aresult xxx
     set acode yyy
@@ -78,6 +85,12 @@ test async-1.6 {basic async handlers} {
     set aresult xxx
     list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
 } {1 foobar {test pattern}}
+test async-1.7 {basic async handlers} {
+    set aresult xxx
+    set acode yyy
+    list [catch {testasync mark $handler4 "original" 0} msg] $msg \
+	   $acode $aresult
+} {0 {comment quoting} 0 original}
 
 proc mult1 {result code} {
     global x
diff --git a/tests/basic.test b/tests/basic.test
index fac8dbf..a16220c 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -15,7 +15,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: basic.test,v 1.28 2003/06/25 23:02:11 dkf Exp $
+# RCS: @(#) $Id: basic.test,v 1.29 2003/07/24 16:05:24 dgp Exp $
 #
 
 package require tcltest 2
@@ -317,6 +317,11 @@ test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespac
          [rename test_ns_basic::test_ns_basic2::p q] \
          [testcmdtoken name $x]
 } {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
+test basic-20.3 {Tcl_GetCommandInfo, #-quoting} {
+    catch {rename \# ""}
+    set x [testcmdtoken create \#]
+    testcmdtoken name $x
+} {{#} ::#}
 
 test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
 } {}
diff --git a/tests/dict.test b/tests/dict.test
index d139c54..f9c5c5a 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -9,7 +9,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: dict.test,v 1.2 2003/04/07 10:12:12 dkf Exp $
+# RCS: @(#) $Id: dict.test,v 1.3 2003/07/24 16:05:24 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -70,6 +70,12 @@ test dict-2.6 {dict create command - initialse refcount field!} {
 	list [dict incr dictv a] 
     } 
 } {}
+test dict-2.7 {dict create command - #-quoting in string rep} {
+    dict create # #comment
+} {{#} #comment}
+test dict-2.8 {dict create command - #-quoting in string rep} -body {
+    dict create #a x #b x
+} -match glob -result {{#?} x #? x}
 
 test dict-3.1 {dict get command} {dict get {a b} a} b
 test dict-3.2 {dict get command} {dict get {a b c d} a} b
diff --git a/tests/dstring.test b/tests/dstring.test
index 6c9276b..5a8b3b2 100644
--- a/tests/dstring.test
+++ b/tests/dstring.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: dstring.test,v 1.5 2000/04/10 17:18:58 ericm Exp $
+# RCS: @(#) $Id: dstring.test,v 1.6 2003/07/24 16:05:24 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -113,6 +113,37 @@ test dstring-2.8 {appending list elements} {
     testdstring element abc
     testdstring get
 } {x abc}
+test dstring-2.9 {appending list elements} {
+    testdstring free
+    testdstring element #
+    testdstring get
+} {{#}}
+test dstring-2.10 {appending list elements} {
+    testdstring free
+    testdstring append " " -1
+    testdstring element #
+    testdstring get
+} { {#}}
+test dstring-2.11 {appending list elements} {
+    testdstring free
+    testdstring append \t -1
+    testdstring element #
+    testdstring get
+} \t{#}
+test dstring-2.12 {appending list elements} {
+    testdstring free
+    testdstring append x -1
+    testdstring element #
+    testdstring get
+} {x #}
+test dstring-2.13 {appending list elements} {
+    # This test shows lack of sophistication in Tcl_DStringAppendElement's
+    # decision about whether #-quoting can be disabled.
+    testdstring free
+    testdstring append "x " -1
+    testdstring element #
+    testdstring get
+} {x {#}}
 
 test dstring-3.1 {nested sublists} {
     testdstring free
@@ -167,6 +198,52 @@ test dstring-3.5 {nested sublists} {
     testdstring end
     testdstring get
 } {\{ {first second}}
+test dstring-3.6 {appending list elements} {
+    testdstring free
+    testdstring append x -1
+    testdstring start
+    testdstring element #
+    testdstring end
+    testdstring get
+} {x {{#}}}
+test dstring-3.7 {appending list elements} {
+    testdstring free
+    testdstring append x -1
+    testdstring start
+    testdstring append " " -1
+    testdstring element #
+    testdstring end
+    testdstring get
+} {x { {#}}}
+test dstring-3.8 {appending list elements} {
+    testdstring free
+    testdstring append x -1
+    testdstring start
+    testdstring append \t -1
+    testdstring element #
+    testdstring end
+    testdstring get
+} "x {\t{#}}"
+test dstring-3.9 {appending list elements} {
+    testdstring free
+    testdstring append x -1
+    testdstring start
+    testdstring append x -1
+    testdstring element #
+    testdstring end
+    testdstring get
+} {x {x #}}
+test dstring-3.10 {appending list elements} {
+    # This test shows lack of sophistication in Tcl_DStringAppendElement's
+    # decision about whether #-quoting can be disabled.
+    testdstring free
+    testdstring append x -1
+    testdstring start
+    testdstring append "x " -1
+    testdstring element #
+    testdstring end
+    testdstring get
+} {x {x {#}}}
 
 test dstring-4.1 {truncation} {
     testdstring free
diff --git a/tests/list.test b/tests/list.test
index 8dd3817..01dc060 100644
--- a/tests/list.test
+++ b/tests/list.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: list.test,v 1.6 2003/03/27 13:19:15 dkf Exp $
+# RCS: @(#) $Id: list.test,v 1.7 2003/07/24 16:05:24 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -44,6 +44,8 @@ test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd"
 test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\
 test list-1.23 {basic tests} {list \{} "\\{"
 test list-1.24 {basic tests} {list} {}
+test list-1.25 {basic tests} {list # #} {{#} #}
+test list-1.26 {basic tests} {list #\{ #\{} {\#\{ #\{}
 
 # For the next round of tests create a list and then pick it apart
 # with "index" to make sure that we get back exactly what went in.
diff --git a/tests/parse.test b/tests/parse.test
index 9764cf1..ee2a772 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -8,7 +8,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: parse.test,v 1.15 2003/04/01 17:08:16 dgp Exp $
+# RCS: @(#) $Id: parse.test,v 1.16 2003/07/24 16:05:24 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -58,10 +58,10 @@ test parse-2.2 {Tcl_ParseCommand procedure, several comments} {
 } foo 1 simple foo 1 text foo 0 {}}
 test parse-2.3 {Tcl_ParseCommand procedure, backslash-newline in comments} {
     testparser " # foo bar\\\ncomment on continuation line\nfoo" 0
-} {#\ foo\ bar\\\ncomment\ on\ continuation\ line\n foo 1 simple foo 1 text foo 0 {}}
+} {\#\ foo\ bar\\\ncomment\ on\ continuation\ line\n foo 1 simple foo 1 text foo 0 {}}
 test parse-2.4 {Tcl_ParseCommand procedure, missing continuation line in comment} {
     testparser "#   \\\n" 0
-} {#\ \ \ \\\n {} 0 {}}
+} {\#\ \ \ \\\n {} 0 {}}
 test parse-2.5 {Tcl_ParseCommand procedure, eof in comment} {
     testparser " # foo bar\nfoo" 8
 } {{# foo b} {} 0 {ar
diff --git a/tests/util.test b/tests/util.test
index fe94732..22b1dbc 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: util.test,v 1.10 2002/01/02 13:52:04 dkf Exp $
+# RCS: @(#) $Id: util.test,v 1.11 2003/07/24 16:05:24 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -43,10 +43,43 @@ test util-3.1 {Tcl_ScanCountedElement procedure - don't leave unmatched braces}
     # Tcl_DStringStartSublist doesn't work.
 
     set x {}
-    lappend x " \\\{ \\"
+    lappend x "# \\\{ \\"
     concat $x [llength "{$x}"]
-} {\ \\\{\ \\ 1}
-
+} {\#\ \\\{\ \\ 1}
+test util-3.2 {Tcl_ConverCountedElement procedure - quote leading '#'} {
+    list # # a
+} {{#} # a}
+test util-3.3 {Tcl_ConverCountedElement procedure - quote leading '#'} {
+    list #\{ # a
+} {\#\{ # a}
+test util-3.4 {Tcl_ConverCountedElement procedure - quote leading '#'} {
+    proc # {} {return #}
+    set result [eval [list #]]
+    rename # {}
+    set result
+} {#}
+test util-3.4.1 {Tcl_ConverCountedElement procedure - quote leading '#'} {
+    proc # {} {return #}
+    set cmd [list #]
+    append cmd ""	;# force string rep generation
+    set result [eval $cmd]
+    rename # {}
+    set result
+} {#}
+test util-3.5 {Tcl_ConverCountedElement procedure - quote leading '#'} {
+    proc #\{ {} {return #}
+    set result [eval [list #\{]]
+    rename #\{ {}
+    set result
+} {#}
+test util-3.5.1 {Tcl_ConverCountedElement procedure - quote leading '#'} {
+    proc #\{ {} {return #}
+    set cmd [list #\{]
+    append cmd ""	;# force string rep generation
+    set result [eval $cmd]
+    rename #\{ {}
+    set result
+} {#}
 test util-4.1 {Tcl_ConcatObj - backslash-space at end of argument} {
     concat a {b\ } c
 } {a b\  c}