1 (* based on Tor Andersson's XML parser from MuPDF's XPS module *)
4 | '
\r'
| '
\n'
| '
\t'
| ' '
-> true
9 | '
.'
| '
-'
| '_'
| '
:'
-> true
10 | c
-> (c
>= '
0'
&& c
<= '
9'
)
11 || (c
>= 'a'
&& c
<= 'z'
)
12 || (c
>= 'A'
&& c
<= 'Z'
)
15 exception Parse_error
of string * string * int;;
17 let parse_error msg s pos
=
18 raise
(Parse_error
(msg
, s
, pos
))
22 let b = Buffer.create len
in
25 then Buffer.contents
b
27 begin match s
.[i
] with
28 | '
<'
-> Buffer.add_string
b "<"
29 | '
>'
-> Buffer.add_string
b ">"
30 | '
\''
-> Buffer.add_string
b "'"
31 | '
\"'
-> Buffer.add_string
b """
32 | '
&'
-> Buffer.add_string
b "&"
34 let code = Char.code c
in
35 if code < 32 || code > 127
37 Buffer.add_string
b "&#";
38 Buffer.add_string
b (string_of_int
code);
39 Buffer.add_char
b '
;'
;
41 else Buffer.add_char
b c
49 let unent b s pos len
=
55 String.index_from s i '
&'
58 if amppos = -1 || amppos >= pos
+ len
59 then Buffer.add_substring
b s i
(pos
+ len
- i
)
61 Buffer.add_substring
b s i
(amppos - i
);
62 if amppos = i
+ len
then Utils.error
"lonely amp";
66 let semipos = String.index_from s
(amppos+1) '
;'
in
67 if semipos >= pos
+ len
then raise Not_found
;
70 Utils.error
"amp not followed by semicolon at %d" amppos
73 let subslen = semipos-amppos-1 in
74 if subslen = 0 then Utils.error
"empty amp at %d" amppos;
76 let subs = String.sub s
(amppos+1) subslen in
81 then Utils.error
"empty amp followed by hash at %d" amppos;
84 then Scanf.sscanf
subs "#x%x" (fun n
-> n
)
85 else int_of_string
(String.sub
subs 1 (subslen-1))
87 let c = Char.unsafe_chr
code in
92 | "lt" -> Buffer.add_char
b '
<'
93 | "gt" -> Buffer.add_char
b '
>'
94 | "amp" -> Buffer.add_char
b '
&'
95 | "apos" -> Buffer.add_char
b '
\''
96 | "quot" -> Buffer.add_char
b '
\"'
97 | _
-> Utils.error
"unknown amp %S" subs
106 let len = String.length s
in
107 let left = len - pos
in
109 then Printf.sprintf
"(pos=%d len=%d left=%d)" pos
len left
111 let len = min
left 10 in
119 | `exclam
-> "exclam"
120 | `question
-> "question"
121 | `doctype
-> "doctype"
122 | `comment
-> "comment"
126 type attr
= string * string
127 and attrs
= attr list
131 | Vopen
of string * attrs
* bool
134 and 'a v
= { f
: 'a v
-> vp
-> int -> int -> 'a v
; accu
: 'a
}
138 let r_comment_terminator = Str.regexp
"-->"
139 and r_CDATA_terminator
= Str.regexp
"\\]\\]>"
140 and r_q_terminator
= Str.regexp
"\\?>" in
142 let slen = String.length s
in
144 let find_substr pos
subs r
=
147 Str.search_forward r s
pos
149 parse_error ("cannot find substring " ^
subs) s
pos
153 let begins_with pos prefix
= Utils.substratis s
pos prefix
in
154 let find_non_white pos =
157 then parse_error "cannot find non white space character" s
pos;
158 if iswhite s
.[i
] then forward (i
+1) else i
in
164 let rec find_non_name i
=
165 if i
>= slen then parse_error "cannot find non name character" s
pos;
166 if isname s
.[i
] then find_non_name (i
+1) else i
170 non_name_pos, String.sub s
pos (non_name_pos - pos)
173 let rec collect v
pos t
=
174 if pos >= slen && t
!= `text
175 then parse_error ("not enough data for " ^
ts t
) s
pos;
181 String.index_from s
pos '
<'
183 let rec trailsbywhite i
=
184 if pos+i
= String.length s
187 if not
(iswhite s
.[pos+i
])
188 then parse_error "garbage at the end" s
pos
189 else trailsbywhite (i
+1)
196 v
.f v Vend
pos slen, slen
198 let start_of_text_pos = find_non_white pos in
199 let end_of_text_pos =
200 if start_of_text_pos < ltpos
203 if i
= start_of_text_pos || not
(iswhite s
.[i
])
208 else start_of_text_pos
211 if start_of_text_pos != end_of_text_pos
212 then v.f
v Vdata
start_of_text_pos end_of_text_pos
215 collect v (ltpos+1) `lt
220 | '
/'
-> (pos+1), `close
221 | '
!'
-> (pos+1), `exclam
222 | '?'
-> (pos+1), `question
223 | c when isname c -> pos, `tag
224 | _
-> parse_error "invalid data after <" s
pos
229 let tag_name_pos = find_non_white pos in
230 let tag_name_end_pos, close_tag_name
= getname tag_name_pos in
231 let close_tag_pos = find_non_white tag_name_end_pos in
232 if s
.[close_tag_pos] != '
>'
233 then parse_error "missing >" s
pos;
234 let pos'
= close_tag_pos + 1 in
235 let v = v.f
v (Vclose close_tag_name
) pos pos'
in
241 String.index_from s
pos '
>'
243 parse_error "doctype is not terminated" s
pos
245 collect v (close_tag_pos+1) `text
250 find_substr pos "-->" r_comment_terminator
252 parse_error "comment is not terminated" s
pos
254 collect v (pos+3) `text
257 if begins_with pos "[CDATA["
259 let cdata_start = pos+7 in
260 let cdata_end = find_substr cdata_start "]]>" r_CDATA_terminator
in
261 let v = v.f
v Vcdata
cdata_start cdata_end in
262 collect v (cdata_end+3) `text
264 if begins_with pos "DOCTYPE"
266 collect v (pos+7) `doctype
268 if begins_with pos "--"
269 then collect v (pos+2) `comment
270 else parse_error "unknown shit after exclamation mark" s
pos
275 let pos = find_substr pos "?>" r_q_terminator
in
276 collect v (pos+2) `text
279 let pos'
, name
= getname pos in
280 let attrs, pos'
, closed
= collect_attributes
pos'
in
281 let v = v.f
v (Vopen
(name
, attrs, closed
)) pos pos'
in
284 and collect_attributes
pos =
287 let pos, name
= getname pos in
288 let pos = find_non_white pos in
293 then parse_error "not enough data for attribute" s
pos;
296 if not
(qc = '
\''
|| qc = '
\"'
)
297 then parse_error "assignment is not followed by a quote" s
pos;
302 then parse_error "not enough data for attribute value" s
pos;
304 if s
.[i
] = qc then i
else find (i
+1)
309 let vallen = closing_q_pos - (qpos+1) in
310 let val'
= String.sub s
(qpos+1) vallen in
311 (name
, val'
), closing_q_pos+1
313 else parse_error "attribute name not followed by '='" s
pos
316 let pos = find_non_white pos in
321 if slen - pos > 2 && s
.[pos] = '
/'
&& s
.[pos+1] = '
>'
327 let nameval, pos = nameval pos in
328 let accu = nameval :: accu in
331 else parse_error "malformed attribute list" s
pos;
337 let _, _ = collect v 0 `text
in