path: root/tools/ucm2tests.tcl

# ucm2tests.tcl
#
# Parses given ucm files (from ICU) to generate test data
# for encodings.
#
#  tclsh ucm2tests.tcl PATH_TO_ICU_UCM_DIRECTORY ?OUTPUTPATH?
#

namespace eval ucm {
    # No means to change these currently but ...
    variable outputPath
    variable outputChan
    variable errorChan stderr
    variable verbose 0

    # Map Tcl encoding name to ICU UCM file name
    variable encNameMap
    array set encNameMap {
        cp1250    glibc-CP1250-2.1.2
        cp1251    glibc-CP1251-2.1.2
        cp1252    glibc-CP1252-2.1.2
        cp1253    glibc-CP1253-2.1.2
        cp1254    glibc-CP1254-2.1.2
        cp1255    glibc-CP1255-2.1.2
        cp1256    glibc-CP1256-2.1.2
        cp1257    glibc-CP1257-2.1.2
        cp1258    glibc-CP1258-2.1.2
        gb1988    glibc-GB_1988_80-2.3.3
        iso8859-1 glibc-ISO_8859_1-2.1.2
        iso8859-2 glibc-ISO_8859_2-2.1.2
        iso8859-3 glibc-ISO_8859_3-2.1.2
        iso8859-4 glibc-ISO_8859_4-2.1.2
        iso8859-5 glibc-ISO_8859_5-2.1.2
        iso8859-6 glibc-ISO_8859_6-2.1.2
        iso8859-7 glibc-ISO_8859_7-2.3.3
        iso8859-8 glibc-ISO_8859_8-2.3.3
        iso8859-9 glibc-ISO_8859_9-2.1.2
        iso8859-10 glibc-ISO_8859_10-2.1.2
        iso8859-11 glibc-ISO_8859_11-2.1.2
        iso8859-13 glibc-ISO_8859_13-2.3.3
        iso8859-14 glibc-ISO_8859_14-2.1.2
        iso8859-15 glibc-ISO_8859_15-2.1.2
        iso8859-16 glibc-ISO_8859_16-2.3.3
    }

    # Array keyed by Tcl encoding name. Each element contains mapping of
    # Unicode code point -> byte sequence for that encoding as a flat list
    # (or dictionary). Both are stored as hex strings
    variable charMap

    # Array keyed by Tcl encoding name. List of invalid code sequences
    # each being a hex string.
    variable invalidCodeSequences

    # Array keyed by Tcl encoding name. List of unicode code points that are
    # not mapped, each being a hex string.
    variable unmappedCodePoints

    # The fallback character per encoding
    variable encSubchar
}

proc ucm::abort {msg} {
    variable errorChan
    puts $errorChan $msg
    exit 1
}
proc ucm::warn {msg} {
    variable errorChan
    puts $errorChan $msg
}
proc ucm::log {msg} {
    variable verbose
    if {$verbose} {
        variable errorChan
        puts $errorChan $msg
    }
}
proc ucm::print {s} {
    variable outputChan
    puts $outputChan $s
}

proc ucm::parse_SBCS {encName fd} {
    variable charMap
    variable invalidCodeSequences
    variable unmappedCodePoints

    set result {}
    while {[gets $fd line] >= 0} {
        if {[string match #* $line]} {
            continue
        }
        if {[string equal "END CHARMAP" [string trim $line]]} {
            break
        }
        if {![regexp {^\s*<U([[:xdigit:]]{4})>\s*((\\x[[:xdigit:]]{2})+)\s*(\|(0|1|2|3|4))} $line -> unichar bytes - - precision]} {
            error "Unexpected line parsing SBCS: $line"
        }
        set bytes [string map {\\x {}} $bytes]; # \xNN -> NN
        if {$precision eq "" || $precision eq "0"} {
            lappend result $unichar $bytes
        } else {
            # It is a fallback mapping - ignore
        }
    }
    set charMap($encName) $result

    # Find out invalid code sequences and unicode code points that are not mapped
    set valid {}
    set mapped {}
    foreach {unich bytes} $result {
        lappend mapped $unich
        lappend valid $bytes
    }
    set invalidCodeSequences($encName) {}
    for {set i 0} {$i <= 255} {incr i} {
        set hex [format %.2X $i]
        if {[lsearch -exact $valid $hex] < 0} {
            lappend invalidCodeSequences($encName) $hex
        }
    }

    set unmappedCodePoints($encName) {}
    for {set i 0} {$i <= 65535} {incr i} {
        set hex [format %.4X $i]
        if {[lsearch -exact $mapped $hex] < 0} {
            lappend unmappedCodePoints($encName) $hex
            # Only look for (at most) one below 256 and one above 1024
            if {$i < 255} {
                # Found one so jump past 8 bits
                set i 255
            } else {
                break
            }
        }
        if {$i == 255} {
            set i 1023
        }
    }
    lappend unmappedCodePoints($encName) D800 DC00 10000 10FFFF
}

proc ucm::generate_boilerplate {} {
    # Common procedures
    print {
# This file is automatically generated by ucm2tests.tcl.
# Edits will be overwritten on next generation.
#
# Generates tests comparing Tcl encodings to ICU.
# The generated file is NOT standalone. It should be sourced into a test script.

proc ucmConvertfromMismatches {enc map} {
    set mismatches {}
    foreach {unihex hex} $map {
        set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
        set unich [subst "\\U$unihex"]
        if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} {
            lappend mismatches "<[printable $unich],$hex>"
        }
    }
    return $mismatches
}
proc ucmConverttoMismatches {enc map} {
    set mismatches {}
    foreach {unihex hex} $map {
        set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
        set unich [subst "\\U$unihex"]
        if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} {
            lappend mismatches "<[printable $unich],$hex>"
        }
    }
    return $mismatches
}
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
    }
}
    }
} ; # generate_boilerplate

proc ucm::generate_tests {} {
    variable encNameMap
    variable charMap
    variable invalidCodeSequences
    variable unmappedCodePoints
    variable outputPath
    variable outputChan
    variable encSubchar

    if {[info exists outputPath]} {
        set outputChan [open $outputPath w]
        fconfigure $outputChan -translation lf
    } else {
        set outputChan stdout
    }

    array set tclNames {}
    foreach encName [encoding names] {
        set tclNames($encName) ""
    }

    generate_boilerplate
    foreach encName [lsort -dictionary [array names encNameMap]] {
        if {![info exists charMap($encName)]} {
            warn "No character map read for $encName"
            continue
        }
        unset tclNames($encName)

        # Print the valid tests
        print "\n#\n# $encName (generated from $encNameMap($encName))"
        print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{"
        print "    ucmConvertfromMismatches $encName {$charMap($encName)}"
        print "\} -result {}"
        print "\ntest encoding-convertto-ucmCompare-$encName {Compare against ICU UCM} -body \{"
        print "    ucmConverttoMismatches $encName {$charMap($encName)}"
        print "\} -result {}"
        if {0} {
            # This will generate individual tests for every char
            # and test in lead, tail, middle, solo configurations
            # but takes considerable time
            print "lappend encValidStrings \{*\}\{"
            foreach {unich hex} $charMap($encName) {
                print "    $encName \\u$unich $hex {} {}"
            }
            print "\}; # $encName"
        }

        # Generate the invalidity checks
        print "\n# $encName - invalid byte sequences"
        print "lappend encInvalidBytes \{*\}\{"
        foreach hex $invalidCodeSequences($encName) {
            # Map XXXX... to \xXX\xXX...
            set uhex [regsub -all .. $hex {\\x\0}]
            set uhex \\U[string range 00000000$hex end-7 end]
            print "    $encName $hex tcl8    $uhex -1 {} {}"
            print "    $encName $hex replace \\uFFFD -1 {} {}"
            print "    $encName $hex strict  {}       0 {} {}"
        }
        print "\}; # $encName"

        print "\n# $encName - invalid byte sequences"
        print "lappend encUnencodableStrings \{*\}\{"
        if {[info exists encSubchar($encName)]} {
            set subchar $encSubchar($encName)
        } else {
            set subchar "3F"; # Tcl uses ? by default
        }
        foreach hex $unmappedCodePoints($encName) {
            set uhex \\U[string range 00000000$hex end-7 end]
            print "    $encName $uhex tcl8    $subchar -1 {} {}"
            print "    $encName $uhex replace $subchar -1 {} {}"
            print "    $encName $uhex strict  {}                      0 {} {}"
        }
        print "\}; # $encName"
    }

    if {[array size tclNames]} {
        warn "Missing encoding: [lsort [array names tclNames]]"
    }
    if {[info exists outputPath]} {
        close $outputChan
        unset outputChan
    }
}

proc ucm::parse_file {encName ucmPath} {
    variable charMap
    variable encSubchar

    set fd [open $ucmPath]
    try {
        # Parse the metadata
        unset -nocomplain state
        while {[gets $fd line] >= 0} {
            if {[regexp {<(code_set_name|mb_cur_max|mb_cur_min|uconv_class|subchar)>\s+(\S+)} $line -> key val]} {
                set state($key) $val
            } elseif {[regexp {^\s*CHARMAP\s*$} $line]} {
                set state(charmap) ""
                break
            } else {
                # Skip all else
            }
        }
        if {![info exists state(charmap)]} {
            abort "Error: $ucmPath has No CHARMAP line."
        }
        foreach key {code_set_name uconv_class} {
            if {[info exists state($key)]} {
                set state($key) [string trim $state($key) {"}]
            }
        }
        if {[info exists charMap($encName)]} {
            abort "Duplicate file for $encName ($path)"
        }
        if {![info exists state(uconv_class)]} {
            abort "Error: $ucmPath has no uconv_class definition."
        }
        if {[info exists state(subchar)]} {
            # \xNN\xNN.. -> NNNN..
            set encSubchar($encName) [string map {\\x {}} $state(subchar)]
        }
        switch -exact -- $state(uconv_class) {
            SBCS {
                if {[catch {
                    parse_SBCS $encName $fd
                } result]} {
                    abort "Could not process $ucmPath. $result"
                }
            }
            default {
                log "Skipping $ucmPath -- not SBCS encoding."
                return
            }
        }
    } finally {
        close $fd
    }
}

proc ucm::run {} {
    variable encNameMap
    variable outputPath
    switch [llength $::argv] {
        2 {set outputPath [lindex $::argv 1]}
        1 {}
        default {
            abort "Usage: [info nameofexecutable] $::argv0 path/to/icu/ucm/data ?outputfile?"
        }
    }
    foreach {encName fname} [array get encNameMap] {
        ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm]
    }
    generate_tests
}

ucm::run