summaryrefslogtreecommitdiffstats
path: root/tests/utfext.test
blob: b980800c8d61813667303b70983417393085a7bb (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
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: