File: uTF8.ml

package info (click to toggle)
extlib 1.7.7-2
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, bullseye, sid
  • size: 632 kB
  • sloc: ml: 6,980; makefile: 128; sh: 42; ansic: 31
file content (225 lines) | stat: -rw-r--r-- 7,798 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
(* 
 * UTF-8 - UTF-8 encoded Unicode string
 * Copyright 2002, 2003 (C) Yamagata Yoriyuki. 
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version,
 * with the special exception on linking described in file LICENSE.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

open UChar

type t = string
type index = int
  
let look s i =
  let n' =
    let n = Char.code s.[i] in
    if n < 0x80 then n else
    if n <= 0xdf then
      (n - 0xc0) lsl 6 lor (0x7f land (Char.code s.[i + 1]))
    else if n <= 0xef then
      let n' = n - 0xe0 in
      let m0 = Char.code s.[i + 2] in
      let m = Char.code (String.unsafe_get s (i + 1)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      n' lsl 6 lor (0x7f land m0)
    else if n <= 0xf7 then
      let n' = n - 0xf0 in
      let m0 = Char.code s.[i + 3] in
      let m = Char.code (String.unsafe_get s (i + 1)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      let m = Char.code (String.unsafe_get s (i + 2)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      n' lsl 6 lor (0x7f land m0)     
    else if n <= 0xfb then
      let n' = n - 0xf8 in
      let m0 = Char.code s.[i + 4] in
      let m = Char.code (String.unsafe_get s (i + 1)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      let m = Char.code (String.unsafe_get s (i + 2)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      let m = Char.code (String.unsafe_get s (i + 3)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      n' lsl 6 lor (0x7f land m0)     
    else if n <= 0xfd then
      let n' = n - 0xfc in
      let m0 = Char.code s.[i + 5] in
      let m = Char.code (String.unsafe_get s (i + 1)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      let m = Char.code (String.unsafe_get s (i + 2)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      let m = Char.code (String.unsafe_get s (i + 3)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      let m = Char.code (String.unsafe_get s (i + 4)) in
      let n' = n' lsl 6 lor (0x7f land m) in
      n' lsl 6 lor (0x7f land m0)
    else invalid_arg "UTF8.look"
  in
  Obj.magic n'

let rec search_head s i =
  if i >= String.length s then i else
  let n = Char.code (String.unsafe_get s i) in
  if n < 0x80 || n >= 0xc2 then i else
  search_head s (i + 1)

let next s i = 
  let n = Char.code s.[i] in
  if n < 0x80 then i + 1 else
  if n < 0xc0 then search_head s (i + 1) else
  if n <= 0xdf then i + 2
  else if n <= 0xef then i + 3
  else if n <= 0xf7 then i + 4
  else if n <= 0xfb then i + 5
  else if n <= 0xfd then i + 6
  else invalid_arg "UTF8.next"

let rec search_head_backward s i =
  if i < 0 then -1 else
  let n = Char.code s.[i] in
  if n < 0x80 || n >= 0xc2 then i else
  search_head_backward s (i - 1)

let prev s i = search_head_backward s (i - 1)

let move s i n =
  if n >= 0 then
    let rec loop i n = if n <= 0 then i else loop (next s i) (n - 1) in
    loop i n
  else
    let rec loop i n = if n >= 0 then i else loop (prev s i) (n + 1) in
    loop i n

let rec nth_aux s i n =
  if n = 0 then i else
  nth_aux s (next s i) (n - 1)

let nth s n = nth_aux s 0 n

let substring s i n =
  let j = nth s i in
  let j' = (nth_aux s j n) - 1 in
  String.sub s j (j' - j + 1)

let last s = search_head_backward s (String.length s - 1)

let out_of_range s i = i < 0 || i >= String.length s

let compare_index _ i j = i - j

let get s n = look s (nth s n)

let add_uchar buf u =
  let masq = 0b111111 in
  let k = int_of_uchar u in
  if k < 0 || k >= 0x4000000 then begin
    Buffer.add_char buf (Char.chr (0xfc + (k lsr 30)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 24) land masq))); 
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
  end else if k <= 0x7f then
    Buffer.add_char buf (Char.unsafe_chr k)
  else if k <= 0x7ff then begin
    Buffer.add_char buf (Char.unsafe_chr (0xc0 lor (k lsr 6)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)))
  end else if k <= 0xffff then begin
    Buffer.add_char buf (Char.unsafe_chr (0xe0 lor (k lsr 12)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
  end else if k <= 0x1fffff then begin
    Buffer.add_char buf (Char.unsafe_chr (0xf0 + (k lsr 18)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
  end else begin
    Buffer.add_char buf (Char.unsafe_chr (0xf8 + (k lsr 24)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
  end 

let init len f =
  let buf = Buffer.create len in
  for c = 0 to len - 1 do add_uchar buf (f c) done;
  Buffer.contents buf

let rec length_aux s c i =
  if i >= String.length s then c else
  let n = Char.code (String.unsafe_get s i) in
  let k =
    if n < 0x80 then 1 else
    if n < 0xc0 then invalid_arg "UTF8.length" else
    if n < 0xe0 then 2 else
    if n < 0xf0 then 3 else
    if n < 0xf8 then 4 else
    if n < 0xfc then 5 else
    if n < 0xfe then 6 else
    invalid_arg "UTF8.length" in
  length_aux s (c + 1) (i + k)

let length s = length_aux s 0 0

let rec iter_aux proc s i =
  if i >= String.length s then () else
  let u = look s i in
  proc u;
  iter_aux proc s (next s i)

let iter proc s = iter_aux proc s 0

let compare s1 s2 = Pervasives.compare s1 s2

exception Malformed_code

let validate s =
  let rec trail c i a =
    if c = 0 then a else
    if i >= String.length s then raise Malformed_code else
    let n = Char.code (String.unsafe_get s i) in
    if n < 0x80 || n >= 0xc0 then raise Malformed_code else
    trail (c - 1) (i + 1) (a lsl 6 lor (n - 0x80)) in
  let rec main i =
    if i >= String.length s then () else
    let n = Char.code (String.unsafe_get s i) in
    if n < 0x80 then main (i + 1) else
    if n < 0xc2 then raise Malformed_code else
    if n <= 0xdf then 
      if trail 1 (i + 1) (n - 0xc0) < 0x80 then raise Malformed_code else 
      main (i + 2)
    else if n <= 0xef then 
      if trail 2 (i + 1) (n - 0xe0) < 0x800 then raise Malformed_code else 
      main (i + 3)
    else if n <= 0xf7 then 
      if trail 3 (i + 1) (n - 0xf0) < 0x10000 then raise Malformed_code else
      main (i + 4)
    else if n <= 0xfb then 
      if trail 4 (i + 1) (n - 0xf8) < 0x200000 then raise Malformed_code else
      main (i + 5)
    else if n <= 0xfd then 
      let n = trail 5 (i + 1) (n - 0xfc) in
      if n lsr 16 < 0x400 then raise Malformed_code else
      main (i + 6)
    else raise Malformed_code in
  main 0

module Buf = 
  struct
    include Buffer
    type buf = t
    let add_char = add_uchar
  end