1 (* based on Tor Andersson's XML parser from MuPDF's XPS module *)
3 let r_comment_terminator = Str.regexp
"-->";;
4 let r_CDATA_terminator = Str.regexp
"\\]\\]>";;
5 let r_q_terminator = Str.regexp
"\\?>";;
8 | '
\r'
| '
\n'
| '
\t'
| ' '
-> true
13 | '
.'
| '
-'
| '_'
| '
:'
-> true
14 | c
-> (c
>= '
0'
&& c
<= '
9'
)
15 || (c
>= 'a'
&& c
<= 'z'
)
16 || (c
>= 'A'
&& c
<= 'Z'
)
19 exception Parse_error
of string * string * int;;
21 let parse_error msg s pos
=
22 raise
(Parse_error
(msg
, s
, pos
))
26 let b = Buffer.create len
in
29 then Buffer.contents
b
31 begin match s
.[i
] with
32 | '
<'
-> Buffer.add_string
b "<"
33 | '
>'
-> Buffer.add_string
b ">"
34 | '
\''
-> Buffer.add_string
b "'"
35 | '
\"'
-> Buffer.add_string
b """
36 | '
&'
-> Buffer.add_string
b "&"
38 let code = Char.code c
in
39 if code < 32 || code > 127
41 Buffer.add_string
b "&#";
42 Buffer.add_string
b (string_of_int
code);
43 Buffer.add_char
b '
;'
;
45 else Buffer.add_char
b c
53 let unent b s pos len
=
59 String.index_from s i '
&'
62 if amppos = -1 || amppos >= pos
+ len
64 Buffer.add_substring
b s i
(pos
+ len
- i
)
67 Buffer.add_substring
b s i
(amppos - i
);
68 if amppos = i
+ len
then Utils.error
"lonely amp";
72 let semipos = String.index_from s
(amppos+1) '
;'
in
73 if semipos >= pos
+ len
then raise Not_found
;
76 Utils.error
"amp not followed by semicolon at %d" amppos
79 let subslen = semipos-amppos-1 in
80 if subslen = 0 then Utils.error
"empty amp at %d" amppos;
82 let subs = String.sub s
(amppos+1) subslen in
87 then Utils.error
"empty amp followed by hash at %d" amppos;
90 then Scanf.sscanf
subs "#x%x" (fun n
-> n
)
91 else int_of_string
(String.sub
subs 1 (subslen-1))
93 let c = Char.unsafe_chr
code in
98 | "lt" -> Buffer.add_char
b '
<'
99 | "gt" -> Buffer.add_char
b '
>'
100 | "amp" -> Buffer.add_char
b '
&'
101 | "apos" -> Buffer.add_char
b '
\''
102 | "quot" -> Buffer.add_char
b '
\"'
103 | _
-> Utils.error
"unknown amp %S" subs
112 let len = String.length s
in
113 let left = len - pos
in
116 Printf.sprintf
"(pos=%d len=%d left=%d)"
119 let len = min
left 10 in
120 let s = String.sub
s pos
len in
128 | `exclam
-> "exclam"
129 | `question
-> "question"
130 | `doctype
-> "doctype"
131 | `comment
-> "comment"
135 type attr
= string * string
136 and attrs
= attr list
140 | Vopen
of string * attrs
* bool
143 and 'a v
= { f
: 'a v
-> vp
-> int -> int -> 'a v
; accu
: 'a
}
147 let slen = String.length
s in
149 let find_substr pos
subs r
=
152 Str.search_forward r
s pos
154 parse_error ("cannot find substring " ^
subs) s pos
158 let begins_with pos prefix
= Utils.substratis
s pos prefix
in
159 let find_non_white pos =
162 then parse_error "cannot find non white space character" s pos;
163 if iswhite s.[i
] then forward (i
+1) else i
in
169 let rec find_non_name i
=
170 if i
>= slen then parse_error "cannot find non name character" s pos;
171 if isname s.[i
] then find_non_name (i
+1) else i
175 non_name_pos, String.sub
s pos (non_name_pos - pos)
178 let rec collect v
pos t
=
179 if pos >= slen && t
!= `text
180 then parse_error ("not enough data for " ^
ts t
) s pos;
186 String.index_from
s pos '
<'
188 let rec trailsbywhite i
=
189 if pos+i
= String.length
s
192 if not
(iswhite s.[pos+i
])
193 then parse_error "garbage at the end" s pos
194 else trailsbywhite (i
+1)
201 v
.f v Vend
pos slen, slen
203 let start_of_text_pos = find_non_white pos in
204 let end_of_text_pos =
205 if start_of_text_pos < ltpos
208 if i
= start_of_text_pos || not
(iswhite s.[i
])
213 else start_of_text_pos
216 if start_of_text_pos != end_of_text_pos
217 then v.f
v Vdata
start_of_text_pos end_of_text_pos
220 collect v (ltpos+1) `lt
225 | '
/'
-> (pos+1), `close
226 | '
!'
-> (pos+1), `exclam
227 | '?'
-> (pos+1), `question
228 | c when isname c -> pos, `tag
229 | _
-> parse_error "invalid data after <" s pos
234 let tag_name_pos = find_non_white pos in
235 let tag_name_end_pos, close_tag_name
= getname tag_name_pos in
236 let close_tag_pos = find_non_white tag_name_end_pos in
237 if s.[close_tag_pos] != '
>'
238 then parse_error "missing >" s pos;
239 let pos'
= close_tag_pos + 1 in
240 let v = v.f
v (Vclose close_tag_name
) pos pos'
in
246 String.index_from
s pos '
>'
248 parse_error "doctype is not terminated" s pos
250 collect v (close_tag_pos+1) `text
255 find_substr pos "-->" r_comment_terminator
257 parse_error "comment is not terminated" s pos
259 collect v (pos+3) `text
262 if begins_with pos "[CDATA["
264 let cdata_start = pos+7 in
265 let cdata_end = find_substr cdata_start "]]>" r_CDATA_terminator in
266 let v = v.f
v Vcdata
cdata_start cdata_end in
267 collect v (cdata_end+3) `text
269 if begins_with pos "DOCTYPE"
271 collect v (pos+7) `doctype
273 if begins_with pos "--"
274 then collect v (pos+2) `comment
275 else parse_error "unknown shit after exclamation mark" s pos
280 let pos = find_substr pos "?>" r_q_terminator in
281 collect v (pos+2) `text
284 let pos'
, name
= getname pos in
285 let attrs, pos'
, closed
= collect_attributes
pos'
in
286 let v = v.f
v (Vopen
(name
, attrs, closed
)) pos pos'
in
289 and collect_attributes
pos =
292 let pos, name
= getname pos in
293 let pos = find_non_white pos in
298 then parse_error "not enough data for attribute" s pos;
301 if not
(qc = '
\''
|| qc = '
\"'
)
302 then parse_error "assignment is not followed by a quote" s pos;
307 then parse_error "not enough data for attribute value" s pos;
309 if s.[i
] = qc then i
else find (i
+1)
314 let vallen = closing_q_pos - (qpos+1) in
315 let val'
= String.sub
s (qpos+1) vallen in
316 (name
, val'
), closing_q_pos+1
318 else parse_error "attribute name not followed by '='" s pos
321 let pos = find_non_white pos in
326 if slen - pos > 2 && s.[pos] = '
/'
&& s.[pos+1] = '
>'
332 let nameval, pos = nameval pos in
333 let accu = nameval :: accu in
336 else parse_error "malformed attribute list" s pos;
342 let _, _ = collect v 0 `text
in