You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
467 lines
16 KiB
467 lines
16 KiB
# |
|
# Copyright (c) 2003-2013, Ashok P. Nadkarni |
|
# All rights reserved. |
|
# |
|
# See the file LICENSE for license |
|
|
|
namespace eval twapi {} |
|
|
|
# Compatibility alias |
|
interp alias {} twapi::get_user_default_langid {} twapi::get_user_langid |
|
interp alias {} twapi::get_system_default_langid {} twapi::get_system_langid |
|
|
|
# |
|
# Format a number |
|
proc twapi::format_number {number lcid args} { |
|
|
|
set number [_verify_number_format $number] |
|
|
|
set lcid [_map_default_lcid_token $lcid] |
|
|
|
# If no options specified, format according to the passed locale |
|
if {[llength $args] == 0} { |
|
return [GetNumberFormat 1 $lcid 0 $number 0 0 0 . "" 0] |
|
} |
|
|
|
array set opts [parseargs args { |
|
idigits.int |
|
ilzero.bool |
|
sgrouping.int |
|
sdecimal.arg |
|
sthousand.arg |
|
inegnumber.int |
|
}] |
|
|
|
# Check the locale for unspecified options |
|
foreach opt {idigits ilzero sgrouping sdecimal sthousand inegnumber} { |
|
if {![info exists opts($opt)]} { |
|
set opts($opt) [lindex [get_locale_info $lcid -$opt] 1] |
|
} |
|
} |
|
|
|
# If number of decimals is -1, see how many decimal places |
|
# in passed string |
|
if {$opts(idigits) == -1} { |
|
lassign [split $number .] whole frac |
|
set opts(idigits) [string length $frac] |
|
} |
|
|
|
# Convert Locale format for grouping to integer calue |
|
if {![string is integer $opts(sgrouping)]} { |
|
# Format assumed to be of the form "N;M;....;0" |
|
set grouping 0 |
|
foreach n [split $opts(sgrouping) {;}] { |
|
if {$n == 0} break |
|
set grouping [expr {$n + 10*$grouping}] |
|
} |
|
set opts(sgrouping) $grouping |
|
} |
|
|
|
set flags 0 |
|
if {[info exists opts(nouseroverride)] && $opts(nouseroverride)} { |
|
setbits flags 0x80000000 |
|
} |
|
return [GetNumberFormat 0 $lcid $flags $number $opts(idigits) \ |
|
$opts(ilzero) $opts(sgrouping) $opts(sdecimal) \ |
|
$opts(sthousand) $opts(inegnumber)] |
|
} |
|
|
|
|
|
# |
|
# Format currency |
|
proc twapi::format_currency {number lcid args} { |
|
|
|
set number [_verify_number_format $number] |
|
|
|
# Get semi-canonical form (get rid of preceding "+" etc.) |
|
# Also verifies number syntax |
|
set number [expr {$number+0}]; |
|
|
|
set lcid [_map_default_lcid_token $lcid] |
|
|
|
# If no options specified, format according to the passed locale |
|
if {[llength $args] == 0} { |
|
return [GetCurrencyFormat 1 $lcid 0 $number 0 0 0 . "" 0 0 ""] |
|
} |
|
|
|
array set opts [parseargs args { |
|
idigits.int |
|
ilzero.bool |
|
sgrouping.int |
|
sdecimal.arg |
|
sthousand.arg |
|
inegcurr.int |
|
icurrency.int |
|
scurrency.arg |
|
}] |
|
|
|
# Check the locale for unspecified options |
|
foreach opt {idigits ilzero sgrouping sdecimal sthousand inegcurr icurrency scurrency} { |
|
if {![info exists opts($opt)]} { |
|
set opts($opt) [lindex [get_locale_info $lcid -$opt] 1] |
|
} |
|
} |
|
|
|
# If number of decimals is -1, see how many decimal places |
|
# in passed string |
|
if {$opts(idigits) == -1} { |
|
lassign [split $number .] whole frac |
|
set opts(idigits) [string length $frac] |
|
} |
|
|
|
# Convert Locale format for grouping to integer calue |
|
if {![string is integer $opts(sgrouping)]} { |
|
# Format assumed to be of the form "N;M;....;0" |
|
set grouping 0 |
|
foreach n [split $opts(sgrouping) {;}] { |
|
if {$n == 0} break |
|
set grouping [expr {$n + 10*$grouping}] |
|
} |
|
set opts(sgrouping) $grouping |
|
} |
|
|
|
set flags 0 |
|
if {[info exists opts(nouseroverride)] && $opts(nouseroverride)} { |
|
setbits flags 0x80000000 |
|
} |
|
|
|
return [GetCurrencyFormat 0 $lcid $flags $number $opts(idigits) \ |
|
$opts(ilzero) $opts(sgrouping) $opts(sdecimal) \ |
|
$opts(sthousand) $opts(inegcurr) \ |
|
$opts(icurrency) $opts(scurrency)] |
|
} |
|
|
|
|
|
# |
|
# Get various info about a locale |
|
proc twapi::get_locale_info {lcid args} { |
|
|
|
set lcid [_map_default_lcid_token $lcid] |
|
|
|
variable locale_info_class_map |
|
if {![info exists locale_info_class_map]} { |
|
# TBD - ilanguage not recommended for Vista. Remove it? |
|
array set locale_info_class_map { |
|
ilanguage 0x00000001 |
|
slanguage 0x00000002 |
|
senglanguage 0x00001001 |
|
sabbrevlangname 0x00000003 |
|
snativelangname 0x00000004 |
|
icountry 0x00000005 |
|
scountry 0x00000006 |
|
sengcountry 0x00001002 |
|
sabbrevctryname 0x00000007 |
|
snativectryname 0x00000008 |
|
idefaultlanguage 0x00000009 |
|
idefaultcountry 0x0000000A |
|
idefaultcodepage 0x0000000B |
|
idefaultansicodepage 0x00001004 |
|
idefaultmaccodepage 0x00001011 |
|
slist 0x0000000C |
|
imeasure 0x0000000D |
|
sdecimal 0x0000000E |
|
sthousand 0x0000000F |
|
sgrouping 0x00000010 |
|
idigits 0x00000011 |
|
ilzero 0x00000012 |
|
inegnumber 0x00001010 |
|
snativedigits 0x00000013 |
|
scurrency 0x00000014 |
|
sintlsymbol 0x00000015 |
|
smondecimalsep 0x00000016 |
|
smonthousandsep 0x00000017 |
|
smongrouping 0x00000018 |
|
icurrdigits 0x00000019 |
|
iintlcurrdigits 0x0000001A |
|
icurrency 0x0000001B |
|
inegcurr 0x0000001C |
|
sdate 0x0000001D |
|
stime 0x0000001E |
|
sshortdate 0x0000001F |
|
slongdate 0x00000020 |
|
stimeformat 0x00001003 |
|
idate 0x00000021 |
|
ildate 0x00000022 |
|
itime 0x00000023 |
|
itimemarkposn 0x00001005 |
|
icentury 0x00000024 |
|
itlzero 0x00000025 |
|
idaylzero 0x00000026 |
|
imonlzero 0x00000027 |
|
s1159 0x00000028 |
|
s2359 0x00000029 |
|
icalendartype 0x00001009 |
|
ioptionalcalendar 0x0000100B |
|
ifirstdayofweek 0x0000100C |
|
ifirstweekofyear 0x0000100D |
|
sdayname1 0x0000002A |
|
sdayname2 0x0000002B |
|
sdayname3 0x0000002C |
|
sdayname4 0x0000002D |
|
sdayname5 0x0000002E |
|
sdayname6 0x0000002F |
|
sdayname7 0x00000030 |
|
sabbrevdayname1 0x00000031 |
|
sabbrevdayname2 0x00000032 |
|
sabbrevdayname3 0x00000033 |
|
sabbrevdayname4 0x00000034 |
|
sabbrevdayname5 0x00000035 |
|
sabbrevdayname6 0x00000036 |
|
sabbrevdayname7 0x00000037 |
|
smonthname1 0x00000038 |
|
smonthname2 0x00000039 |
|
smonthname3 0x0000003A |
|
smonthname4 0x0000003B |
|
smonthname5 0x0000003C |
|
smonthname6 0x0000003D |
|
smonthname7 0x0000003E |
|
smonthname8 0x0000003F |
|
smonthname9 0x00000040 |
|
smonthname10 0x00000041 |
|
smonthname11 0x00000042 |
|
smonthname12 0x00000043 |
|
smonthname13 0x0000100E |
|
sabbrevmonthname1 0x00000044 |
|
sabbrevmonthname2 0x00000045 |
|
sabbrevmonthname3 0x00000046 |
|
sabbrevmonthname4 0x00000047 |
|
sabbrevmonthname5 0x00000048 |
|
sabbrevmonthname6 0x00000049 |
|
sabbrevmonthname7 0x0000004A |
|
sabbrevmonthname8 0x0000004B |
|
sabbrevmonthname9 0x0000004C |
|
sabbrevmonthname10 0x0000004D |
|
sabbrevmonthname11 0x0000004E |
|
sabbrevmonthname12 0x0000004F |
|
sabbrevmonthname13 0x0000100F |
|
spositivesign 0x00000050 |
|
snegativesign 0x00000051 |
|
ipossignposn 0x00000052 |
|
inegsignposn 0x00000053 |
|
ipossymprecedes 0x00000054 |
|
ipossepbyspace 0x00000055 |
|
inegsymprecedes 0x00000056 |
|
inegsepbyspace 0x00000057 |
|
fontsignature 0x00000058 |
|
siso639langname 0x00000059 |
|
siso3166ctryname 0x0000005A |
|
idefaultebcdiccodepage 0x00001012 |
|
ipapersize 0x0000100A |
|
sengcurrname 0x00001007 |
|
snativecurrname 0x00001008 |
|
syearmonth 0x00001006 |
|
ssortname 0x00001013 |
|
idigitsubstitution 0x00001014 |
|
} |
|
} |
|
|
|
# array set opts [parseargs args [array names locale_info_class_map]] |
|
|
|
set result [list ] |
|
foreach opt $args { |
|
lappend result $opt [GetLocaleInfo $lcid $locale_info_class_map([string range $opt 1 end])] |
|
} |
|
return $result |
|
} |
|
|
|
|
|
proc twapi::map_code_page_to_name {cp} { |
|
set code_page_names { |
|
0 "System ANSI default" |
|
1 "System OEM default" |
|
37 "IBM EBCDIC - U.S./Canada" |
|
437 "OEM - United States" |
|
500 "IBM EBCDIC - International" |
|
708 "Arabic - ASMO 708" |
|
709 "Arabic - ASMO 449+, BCON V4" |
|
710 "Arabic - Transparent Arabic" |
|
720 "Arabic - Transparent ASMO" |
|
737 "OEM - Greek (formerly 437G)" |
|
775 "OEM - Baltic" |
|
850 "OEM - Multilingual Latin I" |
|
852 "OEM - Latin II" |
|
855 "OEM - Cyrillic (primarily Russian)" |
|
857 "OEM - Turkish" |
|
858 "OEM - Multlingual Latin I + Euro symbol" |
|
860 "OEM - Portuguese" |
|
861 "OEM - Icelandic" |
|
862 "OEM - Hebrew" |
|
863 "OEM - Canadian-French" |
|
864 "OEM - Arabic" |
|
865 "OEM - Nordic" |
|
866 "OEM - Russian" |
|
869 "OEM - Modern Greek" |
|
870 "IBM EBCDIC - Multilingual/ROECE (Latin-2)" |
|
874 "ANSI/OEM - Thai (same as 28605, ISO 8859-15)" |
|
875 "IBM EBCDIC - Modern Greek" |
|
932 "ANSI/OEM - Japanese, Shift-JIS" |
|
936 "ANSI/OEM - Simplified Chinese (PRC, Singapore)" |
|
949 "ANSI/OEM - Korean (Unified Hangeul Code)" |
|
950 "ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)" |
|
1026 "IBM EBCDIC - Turkish (Latin-5)" |
|
1047 "IBM EBCDIC - Latin 1/Open System" |
|
1140 "IBM EBCDIC - U.S./Canada (037 + Euro symbol)" |
|
1141 "IBM EBCDIC - Germany (20273 + Euro symbol)" |
|
1142 "IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)" |
|
1143 "IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)" |
|
1144 "IBM EBCDIC - Italy (20280 + Euro symbol)" |
|
1145 "IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)" |
|
1146 "IBM EBCDIC - United Kingdom (20285 + Euro symbol)" |
|
1147 "IBM EBCDIC - France (20297 + Euro symbol)" |
|
1148 "IBM EBCDIC - International (500 + Euro symbol)" |
|
1149 "IBM EBCDIC - Icelandic (20871 + Euro symbol)" |
|
1200 "Unicode UCS-2 Little-Endian (BMP of ISO 10646)" |
|
1201 "Unicode UCS-2 Big-Endian" |
|
1250 "ANSI - Central European" |
|
1251 "ANSI - Cyrillic" |
|
1252 "ANSI - Latin I" |
|
1253 "ANSI - Greek" |
|
1254 "ANSI - Turkish" |
|
1255 "ANSI - Hebrew" |
|
1256 "ANSI - Arabic" |
|
1257 "ANSI - Baltic" |
|
1258 "ANSI/OEM - Vietnamese" |
|
1361 "Korean (Johab)" |
|
10000 "MAC - Roman" |
|
10001 "MAC - Japanese" |
|
10002 "MAC - Traditional Chinese (Big5)" |
|
10003 "MAC - Korean" |
|
10004 "MAC - Arabic" |
|
10005 "MAC - Hebrew" |
|
10006 "MAC - Greek I" |
|
10007 "MAC - Cyrillic" |
|
10008 "MAC - Simplified Chinese (GB 2312)" |
|
10010 "MAC - Romania" |
|
10017 "MAC - Ukraine" |
|
10021 "MAC - Thai" |
|
10029 "MAC - Latin II" |
|
10079 "MAC - Icelandic" |
|
10081 "MAC - Turkish" |
|
10082 "MAC - Croatia" |
|
12000 "Unicode UCS-4 Little-Endian" |
|
12001 "Unicode UCS-4 Big-Endian" |
|
20000 "CNS - Taiwan" |
|
20001 "TCA - Taiwan" |
|
20002 "Eten - Taiwan" |
|
20003 "IBM5550 - Taiwan" |
|
20004 "TeleText - Taiwan" |
|
20005 "Wang - Taiwan" |
|
20105 "IA5 IRV International Alphabet No. 5 (7-bit)" |
|
20106 "IA5 German (7-bit)" |
|
20107 "IA5 Swedish (7-bit)" |
|
20108 "IA5 Norwegian (7-bit)" |
|
20127 "US-ASCII (7-bit)" |
|
20261 "T.61" |
|
20269 "ISO 6937 Non-Spacing Accent" |
|
20273 "IBM EBCDIC - Germany" |
|
20277 "IBM EBCDIC - Denmark/Norway" |
|
20278 "IBM EBCDIC - Finland/Sweden" |
|
20280 "IBM EBCDIC - Italy" |
|
20284 "IBM EBCDIC - Latin America/Spain" |
|
20285 "IBM EBCDIC - United Kingdom" |
|
20290 "IBM EBCDIC - Japanese Katakana Extended" |
|
20297 "IBM EBCDIC - France" |
|
20420 "IBM EBCDIC - Arabic" |
|
20423 "IBM EBCDIC - Greek" |
|
20424 "IBM EBCDIC - Hebrew" |
|
20833 "IBM EBCDIC - Korean Extended" |
|
20838 "IBM EBCDIC - Thai" |
|
20866 "Russian - KOI8-R" |
|
20871 "IBM EBCDIC - Icelandic" |
|
20880 "IBM EBCDIC - Cyrillic (Russian)" |
|
20905 "IBM EBCDIC - Turkish" |
|
20924 "IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)" |
|
20932 "JIS X 0208-1990 & 0121-1990" |
|
20936 "Simplified Chinese (GB2312)" |
|
21025 "IBM EBCDIC - Cyrillic (Serbian, Bulgarian)" |
|
21027 "Extended Alpha Lowercase" |
|
21866 "Ukrainian (KOI8-U)" |
|
28591 "ISO 8859-1 Latin I" |
|
28592 "ISO 8859-2 Central Europe" |
|
28593 "ISO 8859-3 Latin 3" |
|
28594 "ISO 8859-4 Baltic" |
|
28595 "ISO 8859-5 Cyrillic" |
|
28596 "ISO 8859-6 Arabic" |
|
28597 "ISO 8859-7 Greek" |
|
28598 "ISO 8859-8 Hebrew" |
|
28599 "ISO 8859-9 Latin 5" |
|
28605 "ISO 8859-15 Latin 9" |
|
29001 "Europa 3" |
|
38598 "ISO 8859-8 Hebrew" |
|
50220 "ISO 2022 Japanese with no halfwidth Katakana" |
|
50221 "ISO 2022 Japanese with halfwidth Katakana" |
|
50222 "ISO 2022 Japanese JIS X 0201-1989" |
|
50225 "ISO 2022 Korean" |
|
50227 "ISO 2022 Simplified Chinese" |
|
50229 "ISO 2022 Traditional Chinese" |
|
50930 "Japanese (Katakana) Extended" |
|
50931 "US/Canada and Japanese" |
|
50933 "Korean Extended and Korean" |
|
50935 "Simplified Chinese Extended and Simplified Chinese" |
|
50936 "Simplified Chinese" |
|
50937 "US/Canada and Traditional Chinese" |
|
50939 "Japanese (Latin) Extended and Japanese" |
|
51932 "EUC - Japanese" |
|
51936 "EUC - Simplified Chinese" |
|
51949 "EUC - Korean" |
|
51950 "EUC - Traditional Chinese" |
|
52936 "HZ-GB2312 Simplified Chinese" |
|
54936 "Windows XP: GB18030 Simplified Chinese (4 Byte)" |
|
57002 "ISCII Devanagari" |
|
57003 "ISCII Bengali" |
|
57004 "ISCII Tamil" |
|
57005 "ISCII Telugu" |
|
57006 "ISCII Assamese" |
|
57007 "ISCII Oriya" |
|
57008 "ISCII Kannada" |
|
57009 "ISCII Malayalam" |
|
57010 "ISCII Gujarati" |
|
57011 "ISCII Punjabi" |
|
65000 "Unicode UTF-7" |
|
65001 "Unicode UTF-8" |
|
} |
|
|
|
# TBD - isn't there a Win32 function to do this ? |
|
set cp [expr {0+$cp}] |
|
if {[dict exists $code_page_names $cp]} { |
|
return [dict get $code_page_names $cp] |
|
} else { |
|
return "Code page $cp" |
|
} |
|
} |
|
|
|
# |
|
# Get the name of a language |
|
interp alias {} twapi::map_langid_to_name {} twapi::VerLanguageName |
|
|
|
# |
|
# Extract language and sublanguage values |
|
proc twapi::extract_primary_langid {langid} { |
|
return [expr {$langid & 0x3ff}] |
|
} |
|
proc twapi::extract_sublanguage_langid {langid} { |
|
return [expr {($langid >> 10) & 0x3f}] |
|
} |
|
|
|
# |
|
# Utility functions |
|
|
|
proc twapi::_map_default_lcid_token {lcid} { |
|
if {$lcid == "systemdefault"} { |
|
return 2048 |
|
} elseif {$lcid == "userdefault"} { |
|
return 1024 |
|
} |
|
return $lcid |
|
} |
|
|
|
proc twapi::_verify_number_format {n} { |
|
set n [string trimleft $n 0] |
|
if {[regexp {^[+-]?[[:digit:]]*(\.)?[[:digit:]]*$} $n]} { |
|
return $n |
|
} else { |
|
error "Invalid numeric format. Must be of a sequence of digits with an optional decimal point and leading plus/minus sign" |
|
} |
|
} |
|
|
|
|
|
|