|
| 1 | +# idna.tcl -- |
| 2 | +# |
| 3 | +# Implementation of IDNA (Internationalized Domain Names for |
| 4 | +# Applications) encoding/decoding system, built on a punycode engine |
| 5 | +# developed directly from the code in RFC 3492, Appendix C (with |
| 6 | +# substantial modifications). |
| 7 | +# |
| 8 | +# This implementation includes code from that RFC, translated to Tcl; the |
| 9 | +# other parts are: |
| 10 | +# Copyright © 2014 Donal K. Fellows |
| 11 | +# |
| 12 | +# See the file "license.terms" for information on usage and redistribution of |
| 13 | +# this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| 14 | + |
| 15 | +namespace eval ::tcl::idna { |
| 16 | + namespace ensemble create -command puny -map { |
| 17 | + encode punyencode |
| 18 | + decode punydecode |
| 19 | + } |
| 20 | + namespace ensemble create -command ::tcl::idna -map { |
| 21 | + encode IDNAencode |
| 22 | + decode IDNAdecode |
| 23 | + puny puny |
| 24 | + version {::apply {{} {package present tcl::idna} ::}} |
| 25 | + } |
| 26 | + |
| 27 | + proc IDNAencode hostname { |
| 28 | + set parts {} |
| 29 | + # Split term from RFC 3490, Sec 3.1 |
| 30 | + foreach part [split $hostname "\x2E\u3002\uFF0E\uFF61"] { |
| 31 | + if {[regexp {[^-A-Za-z0-9]} $part]} { |
| 32 | + if {[regexp {[^-A-Za-z0-9\xA1-\uFFFF]} $part ch]} { |
| 33 | + scan $ch %c c |
| 34 | + if {$ch < "!" || $ch > "~"} { |
| 35 | + set ch [format "\\u%04x" $c] |
| 36 | + } |
| 37 | + throw [list IDNA INVALID_NAME_CHARACTER $ch] \ |
| 38 | + "bad character \"$ch\" in DNS name" |
| 39 | + } |
| 40 | + set part xn--[punyencode $part] |
| 41 | + # Length restriction from RFC 5890, Sec 2.3.1 |
| 42 | + if {[string length $part] > 63} { |
| 43 | + throw [list IDNA OVERLONG_PART $part] \ |
| 44 | + "hostname part too long" |
| 45 | + } |
| 46 | + } |
| 47 | + lappend parts $part |
| 48 | + } |
| 49 | + return [join $parts .] |
| 50 | + } |
| 51 | + proc IDNAdecode hostname { |
| 52 | + set parts {} |
| 53 | + # Split term from RFC 3490, Sec 3.1 |
| 54 | + foreach part [split $hostname "\x2E\u3002\uFF0E\uFF61"] { |
| 55 | + if {[string match -nocase "xn--*" $part]} { |
| 56 | + set part [punydecode [string range $part 4 end]] |
| 57 | + } |
| 58 | + lappend parts $part |
| 59 | + } |
| 60 | + return [join $parts .] |
| 61 | + } |
| 62 | + |
| 63 | + variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""] |
| 64 | + # Bootstring parameters for Punycode |
| 65 | + variable base 36 |
| 66 | + variable tmin 1 |
| 67 | + variable tmax 26 |
| 68 | + variable skew 38 |
| 69 | + variable damp 700 |
| 70 | + variable initial_bias 72 |
| 71 | + variable initial_n 0x80 |
| 72 | + |
| 73 | + variable max_codepoint 0x10FFFF |
| 74 | + |
| 75 | + proc adapt {delta first numchars} { |
| 76 | + variable base |
| 77 | + variable tmin |
| 78 | + variable tmax |
| 79 | + variable damp |
| 80 | + variable skew |
| 81 | + |
| 82 | + set delta [expr {$delta / ($first ? $damp : 2)}] |
| 83 | + incr delta [expr {$delta / $numchars}] |
| 84 | + set k 0 |
| 85 | + while {$delta > ($base - $tmin) * $tmax / 2} { |
| 86 | + set delta [expr {$delta / ($base-$tmin)}] |
| 87 | + incr k $base |
| 88 | + } |
| 89 | + return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}] |
| 90 | + } |
| 91 | + |
| 92 | + # Main punycode encoding function |
| 93 | + proc punyencode {string {case ""}} { |
| 94 | + variable digits |
| 95 | + variable tmin |
| 96 | + variable tmax |
| 97 | + variable base |
| 98 | + variable initial_n |
| 99 | + variable initial_bias |
| 100 | + |
| 101 | + if {![string is boolean $case]} { |
| 102 | + return -code error "\"$case\" must be boolean" |
| 103 | + } |
| 104 | + |
| 105 | + set in {} |
| 106 | + foreach char [set string [split $string ""]] { |
| 107 | + scan $char "%c" ch |
| 108 | + lappend in $ch |
| 109 | + } |
| 110 | + set output {} |
| 111 | + |
| 112 | + # Initialize the state: |
| 113 | + set n $initial_n |
| 114 | + set delta 0 |
| 115 | + set bias $initial_bias |
| 116 | + |
| 117 | + # Handle the basic code points: |
| 118 | + foreach ch $string { |
| 119 | + if {$ch < "\x80"} { |
| 120 | + if {$case eq ""} { |
| 121 | + append output $ch |
| 122 | + } elseif {[string is true $case]} { |
| 123 | + append output [string toupper $ch] |
| 124 | + } elseif {[string is false $case]} { |
| 125 | + append output [string tolower $ch] |
| 126 | + } |
| 127 | + } |
| 128 | + } |
| 129 | + |
| 130 | + set b [string length $output] |
| 131 | + |
| 132 | + # h is the number of code points that have been handled, b is the |
| 133 | + # number of basic code points. |
| 134 | + |
| 135 | + if {$b > 0} { |
| 136 | + append output "-" |
| 137 | + } |
| 138 | + |
| 139 | + # Main encoding loop: |
| 140 | + |
| 141 | + for {set h $b} {$h < [llength $in]} {incr delta; incr n} { |
| 142 | + # All non-basic code points < n have been handled already. Find |
| 143 | + # the next larger one: |
| 144 | + |
| 145 | + set m inf |
| 146 | + foreach ch $in { |
| 147 | + if {$ch >= $n && $ch < $m} { |
| 148 | + set m $ch |
| 149 | + } |
| 150 | + } |
| 151 | + |
| 152 | + # Increase delta enough to advance the decoder's <n,i> state to |
| 153 | + # <m,0>, but guard against overflow: |
| 154 | + |
| 155 | + if {$m-$n > (0xFFFFFFFF-$delta)/($h+1)} { |
| 156 | + throw {PUNYCODE OVERFLOW} "overflow in delta computation" |
| 157 | + } |
| 158 | + incr delta [expr {($m-$n) * ($h+1)}] |
| 159 | + set n $m |
| 160 | + |
| 161 | + foreach ch $in { |
| 162 | + if {$ch < $n && ([incr delta] & 0xFFFFFFFF) == 0} { |
| 163 | + throw {PUNYCODE OVERFLOW} "overflow in delta computation" |
| 164 | + } |
| 165 | + |
| 166 | + if {$ch != $n} { |
| 167 | + continue |
| 168 | + } |
| 169 | + |
| 170 | + # Represent delta as a generalized variable-length integer: |
| 171 | + |
| 172 | + for {set q $delta; set k $base} true {incr k $base} { |
| 173 | + set t [expr {min(max($k-$bias, $tmin), $tmax)}] |
| 174 | + if {$q < $t} { |
| 175 | + break |
| 176 | + } |
| 177 | + append output \ |
| 178 | + [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]] |
| 179 | + set q [expr {($q-$t) / ($base-$t)}] |
| 180 | + } |
| 181 | + |
| 182 | + append output [lindex $digits $q] |
| 183 | + set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]] |
| 184 | + set delta 0 |
| 185 | + incr h |
| 186 | + } |
| 187 | + } |
| 188 | + |
| 189 | + return $output |
| 190 | + } |
| 191 | + |
| 192 | + # Main punycode decode function |
| 193 | + proc punydecode {string {case ""}} { |
| 194 | + variable tmin |
| 195 | + variable tmax |
| 196 | + variable base |
| 197 | + variable initial_n |
| 198 | + variable initial_bias |
| 199 | + variable max_codepoint |
| 200 | + |
| 201 | + if {![string is boolean $case]} { |
| 202 | + return -code error "\"$case\" must be boolean" |
| 203 | + } |
| 204 | + |
| 205 | + # Initialize the state: |
| 206 | + |
| 207 | + set n $initial_n |
| 208 | + set i 0 |
| 209 | + set first 1 |
| 210 | + set bias $initial_bias |
| 211 | + |
| 212 | + # Split the string into the "real" ASCII characters and the ones to |
| 213 | + # feed into the main decoder. Note that we don't need to check the |
| 214 | + # result of [regexp] because that RE will technically match any string |
| 215 | + # at all. |
| 216 | + |
| 217 | + regexp {^(?:(.*)-)?([^-]*)$} $string -> pre post |
| 218 | + if {[string is true -strict $case]} { |
| 219 | + set pre [string toupper $pre] |
| 220 | + } elseif {[string is false -strict $case]} { |
| 221 | + set pre [string tolower $pre] |
| 222 | + } |
| 223 | + set output [split $pre ""] |
| 224 | + set out [llength $output] |
| 225 | + |
| 226 | + # Main decoding loop: |
| 227 | + |
| 228 | + for {set in 0} {$in < [string length $post]} {incr in} { |
| 229 | + # Decode a generalized variable-length integer into delta, which |
| 230 | + # gets added to i. The overflow checking is easier if we increase |
| 231 | + # i as we go, then subtract off its starting value at the end to |
| 232 | + # obtain delta. |
| 233 | + |
| 234 | + for {set oldi $i; set w 1; set k $base} 1 {incr in} { |
| 235 | + if {[set ch [string index $post $in]] eq ""} { |
| 236 | + throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data" |
| 237 | + } |
| 238 | + if {[string match -nocase {[a-z]} $ch]} { |
| 239 | + scan [string toupper $ch] %c digit |
| 240 | + incr digit -65 |
| 241 | + } elseif {[string match {[0-9]} $ch]} { |
| 242 | + set digit [expr {$ch + 26}] |
| 243 | + } else { |
| 244 | + throw {PUNYCODE BAD_INPUT CHAR} \ |
| 245 | + "bad decode character \"$ch\"" |
| 246 | + } |
| 247 | + incr i [expr {$digit * $w}] |
| 248 | + set t [expr {min(max($tmin, $k-$bias), $tmax)}] |
| 249 | + if {$digit < $t} { |
| 250 | + set bias [adapt [expr {$i-$oldi}] $first [incr out]] |
| 251 | + set first 0 |
| 252 | + break |
| 253 | + } |
| 254 | + if {[set w [expr {$w * ($base - $t)}]] > 0x7FFFFFFF} { |
| 255 | + throw {PUNYCODE OVERFLOW} \ |
| 256 | + "excessively large integer computed in digit decode" |
| 257 | + } |
| 258 | + incr k $base |
| 259 | + } |
| 260 | + |
| 261 | + # i was supposed to wrap around from out+1 to 0, incrementing n |
| 262 | + # each time, so we'll fix that now: |
| 263 | + |
| 264 | + if {[incr n [expr {$i / $out}]] > 0x7FFFFFFF} { |
| 265 | + throw {PUNYCODE OVERFLOW} \ |
| 266 | + "excessively large integer computed in character choice" |
| 267 | + } elseif {$n > $max_codepoint} { |
| 268 | + if {$n >= 0x00D800 && $n < 0x00E000} { |
| 269 | + # Bare surrogate?! |
| 270 | + throw {PUNYCODE NON_BMP} \ |
| 271 | + [format "unsupported character U+%06x" $n] |
| 272 | + } |
| 273 | + throw {PUNYCODE NON_UNICODE} "bad codepoint $n" |
| 274 | + } |
| 275 | + set i [expr {$i % $out}] |
| 276 | + |
| 277 | + # Insert n at position i of the output: |
| 278 | + |
| 279 | + set output [linsert $output $i [format "%c" $n]] |
| 280 | + incr i |
| 281 | + } |
| 282 | + |
| 283 | + return [join $output ""] |
| 284 | + } |
| 285 | +} |
| 286 | + |
| 287 | +package provide tcl::idna 1.0.1 |
| 288 | + |
| 289 | +# Local variables: |
| 290 | +# mode: tcl |
| 291 | +# fill-column: 78 |
| 292 | +# End: |
0 commit comments