Merge trunk

1 files changed, 101 insertions, 0 deletions

diff --git a/tests/utfext.test b/tests/utfext.test
new file mode 100644
index 0000000..b980800
--- /dev/null
+++ b/tests/utfext.test
@@ -0,0 +1,101 @@
+# This file contains a collection of tests for Tcl_UtfToExternal and
+# Tcl_UtfToExternal. Sourcing this file into Tcl runs the tests and generates
+# errors. No output means no errors found.
+#
+# Copyright (c) 2023 Ashok P. Nadkarni
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+if {"::tcltest" ni [namespace children]} {
+    package require tcltest 2.5
+    namespace import -force ::tcltest::*
+}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact tcl::test [info patchlevel]]
+
+testConstraint testbytestring [llength [info commands testbytestring]]
+testConstraint testencoding [llength [info commands testencoding]]
+
+# Maps encoded bytes string to utf-8 equivalents, both in hex
+# encoding utf-8 encdata
+lappend utfExtMap {*}{
+    ascii 414243 414243
+}
+
+if {[info commands printable] eq ""} {
+    proc printable {s} {
+        set print ""
+        foreach c [split $s ""] {
+            set i [scan $c %c]
+            if {[string is print $c] && ($i <= 127)} {
+                append print $c
+            } elseif {$i <= 0xff} {
+                append print \\x[format %02X $i]
+            } elseif {$i <= 0xffff} {
+                append print \\u[format %04X $i]
+            } else {
+                append print \\U[format %08X $i]
+            }
+        }
+        return $print
+    }
+}
+
+# Simple test with basic flags
+proc testbasic {direction enc hexin hexout {flags {start end}}} {
+    if {$direction eq "toutf"} {
+        set cmd Tcl_ExternalToUtf
+    } else {
+        set cmd Tcl_UtfToExternal
+    }
+    set in [binary decode hex $hexin]
+    set out [binary decode hex $hexout]
+    set dstlen 40 ;# Should be enough for all encoding tests
+
+    # The C wrapper fills entire destination buffer with FF.
+    # Anything beyond expected output should have FF's
+    set filler [string repeat \xFF $dstlen]
+    set result [string range "$out$filler" 0 $dstlen-1]
+    test $cmd-$enc-$hexin-[join $flags -] "$cmd - $enc - $hexin - $flags" -body \
+        [list testencoding $cmd $enc $in $flags {} $dstlen] \
+        -result [list ok {} $result]
+    foreach profile [encoding profiles] {
+        set flags2 [linsert $flags end profile$profile]
+        test $cmd-$enc-$hexin-[join $flags2 -] "$cmd - $enc - $hexin - $flags" -body \
+            [list testencoding $cmd $enc $in $flags2 {} $dstlen] \
+            -result [list ok {} $result]
+    }
+}
+
+#
+# Basic tests
+foreach {enc utfhex hex} $utfExtMap {
+    # Basic test - TCL_ENCODING_START|TCL_ENCODING_END
+    # Note by default output should be terminated with \0
+    testbasic toutf $enc $hex ${utfhex}00 {start end}
+    testbasic fromutf $enc $utfhex ${hex}00 {start end}
+
+    # Test TCL_ENCODING_NO_TERMINATE
+    testbasic toutf $enc $hex $utfhex {start end noterminate}
+    # knownBug - noterminate not obeyed by fromutf
+    # testbasic fromutf $enc $utfhex $hex {start end noterminate}
+}
+
+# Test for insufficient space
+test xx-bufferoverflow {buffer overflow Tcl_ExternalToUtf} -body {
+    testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1
+} -result [list nospace {} \xFF]
+
+# Another bug - char limit not obeyed
+# % set cv 2
+# % testencoding Tcl_ExternalToUtf utf-8 abcdefgh {start end noterminate charlimit} {} 20 rv wv cv
+# nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
+
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End: