1# stringprep.tcl -*- tcl -*- 2# 3# Implementation of RFC 3454 "Preparation of Internationalized Strings" 4# 5# Copyright (c) 2007 Sergei Golovan 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: stringprep.tcl,v 1.2 2009/11/02 00:26:44 patthoyts Exp $ 11 12package require stringprep::data 1.0 13package require unicode 1.0 14 15namespace eval ::stringprep { 16 variable profiles 17 array unset profiles 18} 19 20######################################################################## 21# Register new stringprep profile 22 23proc ::stringprep::register {profile args} { 24 variable profiles 25 26 array set props [list -mapping "" \ 27 -normalization "" \ 28 -prohibited 0 \ 29 -prohibitedList {} \ 30 -prohibitedCommand "" \ 31 -prohibitedBidi 0] 32 33 foreach {opt val} $args { 34 switch -- $opt { 35 -mapping { 36 foreach tab $val { 37 switch -- $tab { 38 B.1 - B.2 - B.3 {} 39 default { 40 return -code error \ 41 "::stringprep::register -mapping: Only\ 42 B.1, B.2, B.3 tables are allowed" 43 } 44 } 45 } 46 set props(-mapping) $val 47 } 48 -normalization { 49 switch -- $val { 50 D - C - KD - KC - "" { 51 set props(-normalization) $val 52 } 53 default { 54 return -code error \ 55 "::stringprep::register -normalization: Only\ 56 D, C, KD, KC or empty normalization is allowed" 57 } 58 } 59 } 60 -prohibited { 61 set mask 0 62 set c39count 0 63 foreach tab $val { 64 switch -- $tab { 65 A.1 { set mask [expr {$mask | $data::A1Mask}] } 66 C.1.1 { set mask [expr {$mask | $data::C11Mask}] } 67 C.1.2 { set mask [expr {$mask | $data::C12Mask}] } 68 C.2.1 { set mask [expr {$mask | $data::C21Mask}] } 69 C.2.2 { set mask [expr {$mask | $data::C22Mask}] } 70 C.3 - C.4 - C.5 - C.6 - C.7 - C.8 - 71 C.9 { incr c39count } 72 default { 73 return -code error \ 74 "::stringprep::register -prohibited: Only\ 75 tables A.1, C.* are allowed to prohibit" 76 } 77 } 78 } 79 if {$c39count > 0 && $c39count < 7} { 80 return -code error \ 81 "::stringprep::register -prohibited: Must prohibit\ 82 all C.3--C.9 tables or none of them" 83 } 84 if {$c39count > 0} { 85 set mask [expr {$mask | $data::C39Mask}] 86 } 87 set props(-prohibited) $mask 88 } 89 -prohibitedList { 90 if {[catch { 91 foreach uc $val { 92 if {![string is integer -strict $uc]} { 93 error not_integer 94 } else { 95 lappend props(-prohibitedList) [expr {$uc}] 96 } 97 }}]} { 98 return -code error \ 99 "::stringprep::register -prohibitedList: List\ 100 of integers expected" 101 } 102 } 103 -prohibitedCommand { 104 set props(-prohibitedCommand) $val 105 } 106 -prohibitedBidi { 107 if {[string is true -strict $val]} { 108 set props(-prohibitedBidi) 1 109 } elseif {[string is false -strict $val]} { 110 set props(-prohibitedBidi) 0 111 } else { 112 return -code error \ 113 "::stringprep::register -prohibitedBidi: Boolean\ 114 value expected" 115 } 116 } 117 } 118 } 119 set profiles($profile) [array get props] 120} 121 122######################################################################## 123# Register identity profile 124 125::stringprep::register none \ 126 -mapping {} \ 127 -normalization {} \ 128 -prohibited {} \ 129 -prohibitedBidi 0 130 131######################################################################## 132 133proc ::stringprep::stringprep {profile str} { 134 variable profiles 135 136 if {![info exists profiles($profile)]} { 137 return -code error invalid_profile 138 } 139 140 set uclist [::unicode::fromstring $str] 141 142 set uclist [map $profile $uclist] 143 if {[llength $uclist] == 0} { 144 return "" 145 } 146 147 set uclist [normalize $profile $uclist] 148 149 if {[prohibited $profile $uclist]} { 150 return -code error prohibited_character 151 } 152 153 if {[prohibited_bidi $profile $uclist]} { 154 return -code error prohibited_bidi 155 } 156 157 ::unicode::tostring $uclist 158} 159 160######################################################################## 161 162proc ::stringprep::compare {profile str1 str2} { 163 string compare [stringprep $profile $str1] [stringprep $profile $str2] 164} 165 166######################################################################## 167# Mapping (section 3) 168 169proc ::stringprep::map {profile uclist} { 170 variable profiles 171 172 array set props $profiles($profile) 173 174 set B1Mask 0 175 set B3Mask 0 176 set B2 0 177 foreach tab $props(-mapping) { 178 switch -- $tab { 179 B.1 { set B1Mask $data::B1Mask } 180 B.2 { set B2 1 } 181 B.3 { set B3Mask $data::B3Mask } 182 } 183 } 184 185 set res {} 186 foreach uc $uclist { 187 set info [data::GetUniCharInfo $uc] 188 189 if {$info & $B1Mask} { 190 # Map to nothing 191 continue 192 } 193 194 if {$B2 || ($info & $B3Mask)} { 195 if {$info & $data::MCMask} { 196 set res [concat $res [data::GetMC $info]] 197 } else { 198 lappend res [expr {$uc + [data::GetDelta $info]}] 199 } 200 } else { 201 lappend res $uc 202 } 203 } 204 return $res 205} 206 207######################################################################## 208# Normalization (section 4) 209 210proc ::stringprep::normalize {profile uclist} { 211 variable profiles 212 213 array set props $profiles($profile) 214 215 switch -- $props(-normalization) { 216 D - C - KD - KC { 217 return [::unicode::normalize $props(-normalization) $uclist] 218 } 219 default { return $uclist } 220 } 221} 222 223######################################################################## 224# Prohibit (section 5) 225 226proc ::stringprep::prohibited {profile uclist} { 227 variable profiles 228 229 array set props $profiles($profile) 230 231 foreach uc $uclist { 232 set info [data::GetUniCharInfo $uc] 233 if {($info & $props(-prohibited)) || \ 234 [lsearch -exact $props(-prohibitedList) $uc] >= 0} { 235 return 1 236 } elseif {$props(-prohibitedCommand) != "" && \ 237 [uplevel #0 $props(-prohibitedCommand) [list $uc]]} { 238 return 1 239 } 240 } 241 return 0 242} 243 244######################################################################## 245# Check bidi (section 6) 246 247proc ::stringprep::prohibited_bidi {profile uclist} { 248 variable profiles 249 250 array set props $profiles($profile) 251 252 if {!$props(-prohibitedBidi)} { 253 return 0 254 } 255 256 set info [data::GetUniCharInfo [lindex $uclist 0]] 257 set first_ral [expr {$info & $data::D1Mask}] 258 set last_ral 0 259 set have_ral 0 260 set have_l 0 261 foreach uc $uclist { 262 set info [data::GetUniCharInfo $uc] 263 set last_ral [expr {$info & $data::D1Mask}] 264 set have_ral [expr {$have_ral || $last_ral}] 265 set have_l [expr {$have_l || ($info & $data::D2Mask)}] 266 } 267 if {$have_ral && (!$first_ral || !$last_ral || $have_l)} { 268 return 1 269 } else { 270 return 0 271 } 272} 273 274######################################################################## 275 276package provide stringprep 1.0.1 277 278######################################################################## 279