#  idna.tcl --
#
#      This file is a part of the Tkabber XMPP client. It provides support
#      for Internationalizing Domain Names in Applications (IDNA, RFC 3490).
#
#  Copyright (c) 2005 Alexey Shchepin <alexey@sevcom.net>
#
#  SYNOPSIS
#      idna::domain_toascii domain

package provide idna 1.0

##########################################################################

namespace eval idna {}

##########################################################################

proc idna::domain_toascii {domain} {
    set domain [string tolower $domain]
    set parts [split $domain "\u002E\u3002\uFF0E\uFF61"]
    set res {}
    foreach p $parts {
        set r [toascii $p]
        lappend res $r
    }
    return [join $res .]
}

##########################################################################

proc idna::toascii {name} {
    # TODO: Steps 2, 3 and 5 from RFC3490

    if {![string is ascii $name]} {
        set name [punycode_encode $name]
        set name "xn--$name"
    }
    return $name
}

##########################################################################

proc idna::punycode_encode {input} {
    set base 36
    set tmin 1
    set tmax 26
    set skew 38
    set damp 700
    set initial_bias 72
    set initial_n 0x80

    set n $initial_n
    set delta 0
    set out 0
    set bias $initial_bias
    set output ""
    set input_length [string length $input]
    set nonbasic {}

    for {set j 0} {$j < $input_length} {incr j} {
        set c [string index $input $j]
        if {[string is ascii $c]} {
            append output $c
        } else {
            lappend nonbasic $c
        }
    }

    set nonbasic [lsort -unique $nonbasic]

    set h [set b [string length $output]];

    if {$b > 0} {
        append output -
    }

    while {$h < $input_length} {
        set m [scan [string index $nonbasic 0] %c]
        set nonbasic [lrange $nonbasic 1 end]

        incr delta [expr {($m - $n) * ($h + 1)}]
        set n $m

        for {set j 0} {$j < $input_length} {incr j} {
            set c [scan [string index $input $j] %c]

            if {$c < $n} {
                incr delta
            } elseif {$c == $n} {
                for {set q $delta; set k $base} {1} {incr k $base} {
                    set t [expr {$k <= $bias ? $tmin :
                                 $k >= $bias + $tmax ? $tmax : $k - $bias}]
                    if {$q < $t} break;
                    append output \
                        [punycode_encode_digit \
                             [expr {$t + ($q - $t) % ($base - $t)}]]
                    set q [expr {($q - $t) / ($base - $t)}]
                }

                append output [punycode_encode_digit $q]
                set bias [punycode_adapt \
                              $delta [expr {$h + 1}] [expr {$h == $b}]]
                set delta 0
                incr h
            }
        }

        incr delta
        incr n
    }

    return $output;
}

##########################################################################

proc idna::punycode_adapt {delta numpoints firsttime} {
    set base 36
    set tmin 1
    set tmax 26
    set skew 38
    set damp 700

    set delta [expr {$firsttime ? $delta / $damp : $delta >> 1}]
    incr delta [expr {$delta / $numpoints}]

    for {set k 0} {$delta > (($base - $tmin) * $tmax) / 2}  {incr k $base} {
        set delta [expr {$delta / ($base - $tmin)}];
    }

    return [expr {$k + ($base - $tmin + 1) * $delta / ($delta + $skew)}]
}

##########################################################################

proc idna::punycode_encode_digit {d} {
    return [format %c [expr {$d + 22 + 75 * ($d < 26)}]]
}

# vim:ft=tcl:ts=8:sw=4:sts=4:et
