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