#
# 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"
    }
}


