os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/encoding.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/encoding.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,568 @@
1.4 +# This file contains a collection of tests for tclEncoding.c
1.5 +# Sourcing this file into Tcl runs the tests and generates output for
1.6 +# errors. No output means no errors were found.
1.7 +#
1.8 +# Copyright (c) 1997 Sun Microsystems, Inc.
1.9 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.10 +#
1.11 +# See the file "license.terms" for information on usage and redistribution
1.12 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.13 +#
1.14 +# RCS: @(#) $Id: encoding.test,v 1.16.2.3 2006/10/05 21:24:56 hobbs Exp $
1.15 +
1.16 +package require tcltest 2
1.17 +namespace import -force ::tcltest::*
1.18 +
1.19 +proc toutf {args} {
1.20 + global x
1.21 + lappend x "toutf $args"
1.22 +}
1.23 +proc fromutf {args} {
1.24 + global x
1.25 + lappend x "fromutf $args"
1.26 +}
1.27 +
1.28 +# Some tests require the testencoding command
1.29 +testConstraint testencoding [llength [info commands testencoding]]
1.30 +testConstraint exec [llength [info commands exec]]
1.31 +
1.32 +# TclInitEncodingSubsystem is tested by the rest of this file
1.33 +# TclFinalizeEncodingSubsystem is not currently tested
1.34 +
1.35 +test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {
1.36 + testencoding create foo toutf fromutf
1.37 + set old [encoding system]
1.38 + encoding system foo
1.39 + set x {}
1.40 + encoding convertto abcd
1.41 + encoding system $old
1.42 + testencoding delete foo
1.43 + set x
1.44 +} {{fromutf }}
1.45 +test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {
1.46 + testencoding create foo toutf fromutf
1.47 + set x {}
1.48 + encoding convertto foo abcd
1.49 + testencoding delete foo
1.50 + set x
1.51 +} {{fromutf }}
1.52 +test encoding-1.3 {Tcl_GetEncoding: load encoding} {
1.53 + list [encoding convertto jis0208 \u4e4e] \
1.54 + [encoding convertfrom jis0208 8C]
1.55 +} "8C \u4e4e"
1.56 +
1.57 +test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
1.58 + encoding convertto jis0208 \u4e4e
1.59 +} {8C}
1.60 +test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} {
1.61 + set system [encoding system]
1.62 + set path [testencoding path]
1.63 + encoding system shiftjis ;# incr ref count
1.64 + testencoding path [list [pwd]]
1.65 + set x [encoding convertto shiftjis \u4e4e] ;# old one found
1.66 + encoding system identity
1.67 + lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
1.68 + encoding system identity
1.69 + testencoding path $path
1.70 + encoding system $system
1.71 + set x
1.72 +} "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"
1.73 +
1.74 +test encoding-3.1 {Tcl_GetEncodingName, NULL} {
1.75 + set old [encoding system]
1.76 + encoding system shiftjis
1.77 + set x [encoding system]
1.78 + encoding system $old
1.79 + set x
1.80 +} {shiftjis}
1.81 +test encoding-3.2 {Tcl_GetEncodingName, non-null} {
1.82 + set old [fconfigure stdout -encoding]
1.83 + fconfigure stdout -encoding jis0208
1.84 + set x [fconfigure stdout -encoding]
1.85 + fconfigure stdout -encoding $old
1.86 + set x
1.87 +} {jis0208}
1.88 +
1.89 +test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
1.90 + cd [makeDirectory tmp]
1.91 + makeDirectory [file join tmp encoding]
1.92 + makeFile {} [file join tmp encoding junk.enc]
1.93 + makeFile {} [file join tmp encoding junk2.enc]
1.94 + set path [testencoding path]
1.95 + testencoding path {}
1.96 + catch {unset encodings}
1.97 + catch {unset x}
1.98 + foreach encoding [encoding names] {
1.99 + set encodings($encoding) 1
1.100 + }
1.101 + testencoding path [list [pwd]]
1.102 + foreach encoding [encoding names] {
1.103 + if {![info exists encodings($encoding)]} {
1.104 + lappend x $encoding
1.105 + }
1.106 + }
1.107 + testencoding path $path
1.108 + cd [workingDirectory]
1.109 + removeFile [file join tmp encoding junk2.enc]
1.110 + removeFile [file join tmp encoding junk.enc]
1.111 + removeDirectory [file join tmp encoding]
1.112 + removeDirectory tmp
1.113 + lsort $x
1.114 +} {junk junk2}
1.115 +
1.116 +test encoding-5.1 {Tcl_SetSystemEncoding} {
1.117 + set old [encoding system]
1.118 + encoding system jis0208
1.119 + set x [encoding convertto \u4e4e]
1.120 + encoding system identity
1.121 + encoding system $old
1.122 + set x
1.123 +} {8C}
1.124 +test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
1.125 + set old [encoding system]
1.126 + encoding system $old
1.127 + string compare $old [encoding system]
1.128 +} {0}
1.129 +
1.130 +test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} {
1.131 + testencoding create foo {toutf 1} {fromutf 2}
1.132 + set x {}
1.133 + encoding convertfrom foo abcd
1.134 + encoding convertto foo abcd
1.135 + testencoding delete foo
1.136 + set x
1.137 +} {{toutf 1} {fromutf 2}}
1.138 +test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
1.139 + testencoding create foo {toutf a} {fromutf b}
1.140 + set x {}
1.141 + encoding convertfrom foo abcd
1.142 + encoding convertto foo abcd
1.143 + testencoding delete foo
1.144 + set x
1.145 +} {{toutf a} {fromutf b}}
1.146 +
1.147 +test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
1.148 + encoding convertfrom jis0208 8c8c8c8c
1.149 +} "\u543e\u543e\u543e\u543e"
1.150 +test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
1.151 + set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C
1.152 + append a $a
1.153 + append a $a
1.154 + append a $a
1.155 + append a $a
1.156 + set x [encoding convertfrom jis0208 $a]
1.157 + list [string length $x] [string index $x 0]
1.158 +} "512 \u4e4e"
1.159 +
1.160 +test encoding-8.1 {Tcl_ExternalToUtf} {
1.161 + set f [open [file join [temporaryDirectory] dummy] w]
1.162 + fconfigure $f -translation binary -encoding iso8859-1
1.163 + puts -nonewline $f "ab\x8c\xc1g"
1.164 + close $f
1.165 + set f [open [file join [temporaryDirectory] dummy] r]
1.166 + fconfigure $f -translation binary -encoding shiftjis
1.167 + set x [read $f]
1.168 + close $f
1.169 + file delete [file join [temporaryDirectory] dummy]
1.170 + set x
1.171 +} "ab\u4e4eg"
1.172 +
1.173 +test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
1.174 + encoding convertto jis0208 "\u543e\u543e\u543e\u543e"
1.175 +} {8c8c8c8c}
1.176 +test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
1.177 + set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e
1.178 + append a $a
1.179 + append a $a
1.180 + append a $a
1.181 + append a $a
1.182 + append a $a
1.183 + append a $a
1.184 + set x [encoding convertto jis0208 $a]
1.185 + list [string length $x] [string range $x 0 1]
1.186 +} "1024 8C"
1.187 +
1.188 +test encoding-10.1 {Tcl_UtfToExternal} {
1.189 + set f [open [file join [temporaryDirectory] dummy] w]
1.190 + fconfigure $f -translation binary -encoding shiftjis
1.191 + puts -nonewline $f "ab\u4e4eg"
1.192 + close $f
1.193 + set f [open [file join [temporaryDirectory] dummy] r]
1.194 + fconfigure $f -translation binary -encoding iso8859-1
1.195 + set x [read $f]
1.196 + close $f
1.197 + file delete [file join [temporaryDirectory] dummy]
1.198 + set x
1.199 +} "ab\x8c\xc1g"
1.200 +
1.201 +proc viewable {str} {
1.202 + set res ""
1.203 + foreach c [split $str {}] {
1.204 + if {[string is print $c] && [string is ascii $c]} {
1.205 + append res $c
1.206 + } else {
1.207 + append res "\\u[format %4.4x [scan $c %c]]"
1.208 + }
1.209 + }
1.210 + return "$str ($res)"
1.211 +}
1.212 +
1.213 +test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
1.214 + set system [encoding system]
1.215 + set path [testencoding path]
1.216 + encoding system iso8859-1
1.217 + testencoding path {}
1.218 + set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg]
1.219 + testencoding path $path
1.220 + encoding system $system
1.221 + lappend x [encoding convertto jis0208 \u4e4e]
1.222 +} {1 {unknown encoding "jis0208"} 8C}
1.223 +test encoding-11.2 {LoadEncodingFile: single-byte} {
1.224 + encoding convertfrom jis0201 \xa1
1.225 +} "\uff61"
1.226 +test encoding-11.3 {LoadEncodingFile: double-byte} {
1.227 + encoding convertfrom jis0208 8C
1.228 +} "\u4e4e"
1.229 +test encoding-11.4 {LoadEncodingFile: multi-byte} {
1.230 + encoding convertfrom shiftjis \x8c\xc1
1.231 +} "\u4e4e"
1.232 +test encoding-11.5 {LoadEncodingFile: escape file} {
1.233 + viewable [encoding convertto iso2022 \u4e4e]
1.234 +} [viewable "\x1b\$B8C\x1b(B"]
1.235 +test encoding-11.5.1 {LoadEncodingFile: escape file} {
1.236 + viewable [encoding convertto iso2022-jp \u4e4e]
1.237 +} [viewable "\x1b\$B8C\x1b(B"]
1.238 +test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
1.239 + set system [encoding system]
1.240 + set path [testencoding path]
1.241 + encoding system identity
1.242 + cd [temporaryDirectory]
1.243 + testencoding path tmp
1.244 + makeDirectory tmp
1.245 + makeDirectory [file join tmp encoding]
1.246 + set f [open [file join tmp encoding splat.enc] w]
1.247 + fconfigure $f -translation binary
1.248 + puts $f "abcdefghijklmnop"
1.249 + close $f
1.250 + set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]
1.251 + file delete [file join [temporaryDirectory] tmp encoding splat.enc]
1.252 + removeDirectory [file join tmp encoding]
1.253 + removeDirectory tmp
1.254 + cd [workingDirectory]
1.255 + testencoding path $path
1.256 + encoding system $system
1.257 + set x
1.258 +} {1 {invalid encoding file "splat"}}
1.259 +
1.260 +# OpenEncodingFile is fully tested by the rest of the tests in this file.
1.261 +
1.262 +test encoding-12.1 {LoadTableEncoding: normal encoding} {
1.263 + set x [encoding convertto iso8859-3 \u120]
1.264 + append x [encoding convertto iso8859-3 \ud5]
1.265 + append x [encoding convertfrom iso8859-3 \xd5]
1.266 +} "\xd5?\u120"
1.267 +test encoding-12.2 {LoadTableEncoding: single-byte encoding} {
1.268 + set x [encoding convertto iso8859-3 ab\u0120g]
1.269 + append x [encoding convertfrom iso8859-3 ab\xd5g]
1.270 +} "ab\xd5gab\u120g"
1.271 +test encoding-12.3 {LoadTableEncoding: multi-byte encoding} {
1.272 + set x [encoding convertto shiftjis ab\u4e4eg]
1.273 + append x [encoding convertfrom shiftjis ab\x8c\xc1g]
1.274 +} "ab\x8c\xc1gab\u4e4eg"
1.275 +test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
1.276 + set x [encoding convertto jis0208 \u4e4e\u3b1]
1.277 + append x [encoding convertfrom jis0208 8C&A]
1.278 +} "8C&A\u4e4e\u3b1"
1.279 +test encoding-12.5 {LoadTableEncoding: symbol encoding} {
1.280 + set x [encoding convertto symbol \u3b3]
1.281 + append x [encoding convertto symbol \u67]
1.282 + append x [encoding convertfrom symbol \x67]
1.283 +} "\x67\x67\u3b3"
1.284 +
1.285 +test encoding-13.1 {LoadEscapeTable} {
1.286 + viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
1.287 +} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]
1.288 +
1.289 +test encoding-14.1 {BinaryProc} {
1.290 + encoding convertto identity \x12\x34\x56\xff\x69
1.291 +} "\x12\x34\x56\xc3\xbf\x69"
1.292 +
1.293 +test encoding-15.1 {UtfToUtfProc} {
1.294 + encoding convertto utf-8 \xa3
1.295 +} "\xc2\xa3"
1.296 +
1.297 +test encoding-15.2 {UtfToUtfProc null character output} {
1.298 + set x \u0000
1.299 + set y [encoding convertto utf-8 \u0000]
1.300 + set y [encoding convertfrom identity $y]
1.301 + binary scan $y H* z
1.302 + list [string bytelength $x] [string bytelength $y] $z
1.303 +} {2 1 00}
1.304 +
1.305 +test encoding-15.3 {UtfToUtfProc null character input} {
1.306 + set x [encoding convertfrom identity \x00]
1.307 + set y [encoding convertfrom utf-8 $x]
1.308 + binary scan [encoding convertto identity $y] H* z
1.309 + list [string bytelength $x] [string bytelength $y] $z
1.310 +} {1 2 c080}
1.311 +
1.312 +test encoding-16.1 {UnicodeToUtfProc} {
1.313 + set val [encoding convertfrom unicode NN]
1.314 + list $val [format %x [scan $val %c]]
1.315 +} "\u4e4e 4e4e"
1.316 +
1.317 +test encoding-17.1 {UtfToUnicodeProc} {
1.318 +} {}
1.319 +
1.320 +test encoding-18.1 {TableToUtfProc} {
1.321 +} {}
1.322 +
1.323 +test encoding-19.1 {TableFromUtfProc} {
1.324 +} {}
1.325 +
1.326 +test encoding-20.1 {TableFreefProc} {
1.327 +} {}
1.328 +
1.329 +test encoding-21.1 {EscapeToUtfProc} {
1.330 +} {}
1.331 +
1.332 +test encoding-22.1 {EscapeFromUtfProc} {
1.333 +} {}
1.334 +
1.335 +set ::iso2022encData "\u001b\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\u001b(B
1.336 +\u001b\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\u001b(B
1.337 +\u001b\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\u001b(B
1.338 +casino_japanese@___.com \u001b\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\u001b(B
1.339 +\u001b\$B\$7\$g\$&\$+!)\u001b(B"
1.340 +
1.341 +set ::iso2022uniData [encoding convertfrom iso2022-jp $::iso2022encData]
1.342 +set ::iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
1.343 +\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a
1.344 +\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08
1.345 +\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067
1.346 +\u3057\u3087\u3046\u304b\uff1f"
1.347 +
1.348 +cd [temporaryDirectory]
1.349 +set fid [open iso2022.txt w]
1.350 +fconfigure $fid -encoding binary
1.351 +puts -nonewline $fid $::iso2022encData
1.352 +close $fid
1.353 +
1.354 +test encoding-23.1 {iso2022-jp escape encoding test} {
1.355 + string equal $::iso2022uniData $::iso2022uniData2
1.356 +} 1
1.357 +test encoding-23.2 {iso2022-jp escape encoding test} {
1.358 + # This checks that 'gets' isn't resetting the encoding inappropriately.
1.359 + # [Bug #523988]
1.360 + set fid [open iso2022.txt r]
1.361 + fconfigure $fid -encoding iso2022-jp
1.362 + set out ""
1.363 + set count 0
1.364 + while {[set num [gets $fid line]] >= 0} {
1.365 + if {$count} {
1.366 + incr count 1 ; # account for newline
1.367 + append out \n
1.368 + }
1.369 + append out $line
1.370 + incr count $num
1.371 + }
1.372 + close $fid
1.373 + if {[string compare $::iso2022uniData $out]} {
1.374 + return -code error "iso2022-jp read in doesn't match original"
1.375 + }
1.376 + list $count $out
1.377 +} [list [string length $::iso2022uniData] $::iso2022uniData]
1.378 +test encoding-23.3 {iso2022-jp escape encoding test} {
1.379 + # read $fis <size> reads size in chars, not raw bytes.
1.380 + set fid [open iso2022.txt r]
1.381 + fconfigure $fid -encoding iso2022-jp
1.382 + set data [read $fid 50]
1.383 + close $fid
1.384 + set data
1.385 +} [string range $::iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
1.386 +cd [workingDirectory]
1.387 +
1.388 +test encoding-24.1 {EscapeFreeProc on open channels} -constraints {
1.389 + exec
1.390 +} -setup {
1.391 + # Bug #524674 input
1.392 + set file [makeFile {
1.393 + set f [open [file join [file dirname [info script]] iso2022.txt]]
1.394 + fconfigure $f -encoding iso2022-jp
1.395 + gets $f
1.396 + } iso2022.tcl]
1.397 +} -body {
1.398 + exec [interpreter] $file
1.399 +} -cleanup {
1.400 + removeFile iso2022.tcl
1.401 +} -result {}
1.402 +
1.403 +test encoding-24.2 {EscapeFreeProc on open channels} -constraints {
1.404 + exec
1.405 +} -setup {
1.406 + # Bug #524674 output
1.407 + set file [makeFile {
1.408 + fconfigure stdout -encoding iso2022-jp
1.409 + puts ab\u4e4e\u68d9g
1.410 + exit
1.411 + } iso2022.tcl]
1.412 +} -body {
1.413 + viewable [exec [interpreter] $file]
1.414 +} -cleanup {
1.415 + removeFile iso2022.tcl
1.416 +} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
1.417 +
1.418 +test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
1.419 + # Bug #219314 - if we don't free escape encodings correctly on
1.420 + # channel closure, we go boom
1.421 + set file [makeFile {
1.422 + encoding system iso2022-jp
1.423 + set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
1.424 + puts $a
1.425 + } iso2022.tcl]
1.426 + set f [open "|[list [interpreter] $file]"]
1.427 + fconfigure $f -encoding iso2022-jp
1.428 + set count [gets $f line]
1.429 + close $f
1.430 + removeFile iso2022.tcl
1.431 + list $count [viewable $line]
1.432 +} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"]
1.433 +
1.434 +file delete [file join [temporaryDirectory] iso2022.txt]
1.435 +
1.436 +#
1.437 +# Begin jajp encoding round-trip conformity tests
1.438 +#
1.439 +proc foreach-jisx0208 {varName command} {
1.440 + upvar 1 $varName code
1.441 + foreach range {
1.442 + {2121 217E}
1.443 + {2221 222E}
1.444 + {223A 2241}
1.445 + {224A 2250}
1.446 + {225C 226A}
1.447 + {2272 2279}
1.448 + {227E 227E}
1.449 + {2330 2339}
1.450 + {2421 2473}
1.451 + {2521 2576}
1.452 + {2821 2821}
1.453 + {282C 282C}
1.454 + {2837 2837}
1.455 +
1.456 + {30 21 4E 7E}
1.457 + {4F21 4F53}
1.458 +
1.459 + {50 21 73 7E}
1.460 + {7421 7426}
1.461 + } {
1.462 + if {[llength $range] == 2} {
1.463 + # for adhoc range. simple {first last}. inclusive.
1.464 + set first [scan [lindex $range 0] %x]
1.465 + set last [scan [lindex $range 1] %x]
1.466 + for {set i $first} {$i <= $last} {incr i} {
1.467 + set code $i
1.468 + uplevel 1 $command
1.469 + }
1.470 + } elseif {[llength $range] == 4} {
1.471 + # for uniform range.
1.472 + set h0 [scan [lindex $range 0] %x]
1.473 + set l0 [scan [lindex $range 1] %x]
1.474 + set hend [scan [lindex $range 2] %x]
1.475 + set lend [scan [lindex $range 3] %x]
1.476 + for {set hi $h0} {$hi <= $hend} {incr hi} {
1.477 + for {set lo $l0} {$lo <= $lend} {incr lo} {
1.478 + set code [expr {$hi << 8 | ($lo & 0xff)}]
1.479 + uplevel 1 $command
1.480 + }
1.481 + }
1.482 + } else {
1.483 + error "really?"
1.484 + }
1.485 + }
1.486 +}
1.487 +proc gen-jisx0208-euc-jp {code} {
1.488 + binary format cc \
1.489 + [expr {($code >> 8) | 0x80}] [expr {($code & 0xff) | 0x80}]
1.490 +}
1.491 +proc gen-jisx0208-iso2022-jp {code} {
1.492 + binary format a3cca3 \
1.493 + "\x1b\$B" [expr {$code >> 8}] [expr {$code & 0xff}] "\x1b(B"
1.494 +}
1.495 +proc gen-jisx0208-cp932 {code} {
1.496 + set c1 [expr {($code >> 8) | 0x80}]
1.497 + set c2 [expr {($code & 0xff)| 0x80}]
1.498 + if {$c1 % 2} {
1.499 + set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x31 : 0x71)}]
1.500 + incr c2 [expr {- (0x60 + ($c2 < 0xe0))}]
1.501 + } else {
1.502 + set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x30 : 0x70)}]
1.503 + incr c2 -2
1.504 + }
1.505 + binary format cc $c1 $c2
1.506 +}
1.507 +proc channel-diff {fa fb} {
1.508 + set diff {}
1.509 + while {[gets $fa la] >= 0 && [gets $fb lb] >= 0} {
1.510 + if {[string compare $la $lb] == 0} continue
1.511 + # lappend diff $la $lb
1.512 +
1.513 + # For more readable (easy to analyze) output.
1.514 + set code [lindex $la 0]
1.515 + binary scan [lindex $la 1] H* expected
1.516 + binary scan [lindex $lb 1] H* got
1.517 + lappend diff [list $code $expected $got]
1.518 + }
1.519 + set diff
1.520 +}
1.521 +
1.522 +# Create char tables.
1.523 +cd [temporaryDirectory]
1.524 +foreach enc {cp932 euc-jp iso2022-jp} {
1.525 + set f [open $enc.chars w]
1.526 + fconfigure $f -encoding binary
1.527 + foreach-jisx0208 code {
1.528 + puts $f [format "%04X %s" $code [gen-jisx0208-$enc $code]]
1.529 + }
1.530 + close $f
1.531 +}
1.532 +# shiftjis == cp932 for jisx0208.
1.533 +file copy -force cp932.chars shiftjis.chars
1.534 +
1.535 +set NUM 0
1.536 +foreach from {cp932 shiftjis euc-jp iso2022-jp} {
1.537 + foreach to {cp932 shiftjis euc-jp iso2022-jp} {
1.538 + test encoding-25.[incr NUM] "jisx0208 $from => $to" {
1.539 + cd [temporaryDirectory]
1.540 + set f [open $from.chars]
1.541 + fconfigure $f -encoding $from
1.542 + set out [open $from.$to.out w]
1.543 + fconfigure $out -encoding $to
1.544 + puts -nonewline $out [read $f]
1.545 + close $out
1.546 + close $f
1.547 +
1.548 + # then compare $to.chars <=> $from.to.out as binary.
1.549 + set fa [open $to.chars]
1.550 + fconfigure $fa -encoding binary
1.551 + set fb [open $from.$to.out]
1.552 + fconfigure $fb -encoding binary
1.553 + set diff [channel-diff $fa $fb]
1.554 + close $fa
1.555 + close $fb
1.556 +
1.557 + # Difference should be empty.
1.558 + set diff
1.559 + } {}
1.560 + }
1.561 +}
1.562 +
1.563 +eval [list file delete] [glob -directory [temporaryDirectory] *.chars *.out]
1.564 +# ===> Cut here <===
1.565 +
1.566 +# EscapeFreeProc, GetTableEncoding, unilen
1.567 +# are fully tested by the rest of this file
1.568 +
1.569 +# cleanup
1.570 +::tcltest::cleanupTests
1.571 +return