blob: 827fd04ebd3d44b770be3f9f0a2a30f87cc06205 (
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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
#----------------------------------------------------------------------
#
# icu.tcl --
#
# This file implements the portions of the [tcl::unsupported::icu]
# ensemble that are coded in Tcl.
#
#----------------------------------------------------------------------
#
# Copyright © 2024 Ashok P. Nadkarni
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#----------------------------------------------------------------------
::tcl::unsupported::loadIcu
namespace eval ::tcl::unsupported::icu {
# Map Tcl encoding names to ICU and back. Note ICU has multiple aliases
# for the same encoding.
variable tclToIcu
variable icuToTcl
proc LogError {message} {
puts stderr $message
}
proc Init {} {
variable tclToIcu
variable icuToTcl
# There are some special cases where names do not line up
# at all. Map Tcl -> ICU
array set specialCases {
ebcdic ebcdic-cp-us
macCentEuro maccentraleurope
utf16 UTF16_PlatformEndian
utf-16be UnicodeBig
utf-16le UnicodeLittle
utf32 UTF32_PlatformEndian
}
# Ignore all errors. Do not want to hold up Tcl
# if ICU not available
if {[catch {
foreach tclName [encoding names] {
if {[catch {
set icuNames [aliases $tclName]
} erMsg]} {
LogError "Could not get aliases for $tclName: $erMsg"
continue
}
if {[llength $icuNames] == 0} {
# E.g. macGreek -> x-MacGreek
set icuNames [aliases x-$tclName]
if {[llength $icuNames] == 0} {
# Still no joy, check for special cases
if {[info exists specialCases($tclName)]} {
set icuNames [aliases $specialCases($tclName)]
}
}
}
# If the Tcl name is also an ICU name use it else use
# the first name which is the canonical ICU name
set pos [lsearch -exact -nocase $icuNames $tclName]
if {$pos >= 0} {
lappend tclToIcu($tclName) [lindex $icuNames $pos] {*}[lreplace $icuNames $pos $pos]
} else {
set tclToIcu($tclName) $icuNames
}
foreach icuName $icuNames {
lappend icuToTcl($icuName) $tclName
}
}
} errMsg]} {
LogError $errMsg
}
array default set tclToIcu ""
array default set icuToTcl ""
# Redefine ourselves to no-op.
proc Init {} {}
}
# Primarily used during development
proc MappedIcuNames {{pat *}} {
Init
variable icuToTcl
return [array names icuToTcl $pat]
}
# Primarily used during development
proc UnmappedIcuNames {{pat *}} {
Init
variable icuToTcl
set unmappedNames {}
foreach icuName [converters] {
if {[llength [icuToTcl $icuName]] == 0} {
lappend unmappedNames $icuName
}
foreach alias [aliases $icuName] {
if {[llength [icuToTcl $alias]] == 0} {
lappend unmappedNames $alias
}
}
}
# Aliases can be duplicates. Remove
return [lsort -unique [lsearch -inline -all $unmappedNames $pat]]
}
# Primarily used during development
proc UnmappedTclNames {{pat *}} {
Init
variable tclToIcu
set unmappedNames {}
foreach tclName [encoding names] {
# Note entry will always exist. Check if empty
if {[llength [tclToIcu $tclName]] == 0} {
lappend unmappedNames $tclName
}
}
return [lsearch -inline -all $unmappedNames $pat]
}
# Returns the Tcl equivalent of an ICU encoding name or
# the empty string in case not found.
proc icuToTcl {icuName} {
Init
proc icuToTcl {icuName} {
variable icuToTcl
return [lindex $icuToTcl($icuName) 0]
}
icuToTcl $icuName
}
# Returns the ICU equivalent of an Tcl encoding name or
# the empty string in case not found.
proc tclToIcu {tclName} {
Init
proc tclToIcu {tclName} {
variable tclToIcu
return [lindex $tclToIcu($tclName) 0]
}
tclToIcu $tclName
}
namespace export {[a-z]*}
namespace ensemble create
}
|
