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
|
(*
* Xml Light, an small Xml parser/printer with DTD support.
* Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
*
* 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.
*
* 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 Printf
open Xml_parser
exception Not_element of xml
exception Not_pcdata of xml
exception No_attribute of string
let default_parser = Xml_parser.make()
let parse (p:Xml_parser.t) (source:Xml_parser.source) =
(* local cast Xml.xml -> xml *)
(Obj.magic Xml_parser.parse p source : xml)
let parse_in ch = parse default_parser (Xml_parser.SChannel ch)
let parse_string str = parse default_parser (Xml_parser.SString str)
let parse_file f = parse default_parser (Xml_parser.SFile f)
let tag = function
| Element (tag,_,_) -> tag
| x -> raise (Not_element x)
let pcdata = function
| PCData text -> text
| x -> raise (Not_pcdata x)
let attribs = function
| Element (_,attr,_) -> attr
| x -> raise (Not_element x)
let attrib x att =
match x with
| Element (_,attr,_) ->
(try
let att = String.lowercase att in
snd (List.find (fun (n,_) -> String.lowercase n = att) attr)
with
Not_found ->
raise (No_attribute att))
| x ->
raise (Not_element x)
let children = function
| Element (_,_,clist) -> clist
| x -> raise (Not_element x)
(*let enum = function
| Element (_,_,clist) -> List.to_enum clist
| x -> raise (Not_element x)
*)
let iter f = function
| Element (_,_,clist) -> List.iter f clist
| x -> raise (Not_element x)
let map f = function
| Element (_,_,clist) -> List.map f clist
| x -> raise (Not_element x)
let fold f v = function
| Element (_,_,clist) -> List.fold_left f v clist
| x -> raise (Not_element x)
let tmp = Buffer.create 200
let buffer_pcdata text =
let l = String.length text in
for p = 0 to l-1 do
match text.[p] with
| '>' -> Buffer.add_string tmp ">"
| '<' -> Buffer.add_string tmp "<"
| '&' ->
if p < l-1 && text.[p+1] = '#' then
Buffer.add_char tmp '&'
else
Buffer.add_string tmp "&"
| '\'' -> Buffer.add_string tmp "'"
| '"' -> Buffer.add_string tmp """
| c -> Buffer.add_char tmp c
done
let print_pcdata chan text =
let l = String.length text in
for p = 0 to l-1 do
match text.[p] with
| '>' -> Printf.fprintf chan ">"
| '<' -> Printf.fprintf chan "<"
| '&' ->
if p < l-1 && text.[p+1] = '#' then
Printf.fprintf chan "&"
else
Printf.fprintf chan "&"
| '\'' -> Printf.fprintf chan "'"
| '"' -> Printf.fprintf chan """
| c -> Printf.fprintf chan "%c" c
done
let buffer_attr (n,v) =
Buffer.add_char tmp ' ';
Buffer.add_string tmp n;
Buffer.add_string tmp "=\"";
let l = String.length v in
for p = 0 to l-1 do
match v.[p] with
| '\\' -> Buffer.add_string tmp "\\\\"
| '"' -> Buffer.add_string tmp "\\\""
| c -> Buffer.add_char tmp c
done;
Buffer.add_char tmp '"'
let rec print_attr chan (n, v) =
Printf.fprintf chan " %s=\"" n;
let l = String.length v in
for p = 0 to l-1 do
match v.[p] with
| '\\' -> Printf.fprintf chan "\\\\"
| '"' -> Printf.fprintf chan "\\\""
| c -> Printf.fprintf chan "%c" c
done;
Printf.fprintf chan "\""
let print_attrs chan l = List.iter (print_attr chan) l
let rec print_xml chan = function
| Element (tag, alist, []) ->
Printf.fprintf chan "<%s%a/>" tag print_attrs alist;
| Element (tag, alist, l) ->
Printf.fprintf chan "<%s%a>%a</%s>" tag print_attrs alist
(fun chan -> List.iter (print_xml chan)) l tag
| PCData text ->
print_pcdata chan text
let to_string x =
let pcdata = ref false in
let rec loop = function
| Element (tag,alist,[]) ->
Buffer.add_char tmp '<';
Buffer.add_string tmp tag;
List.iter buffer_attr alist;
Buffer.add_string tmp "/>";
pcdata := false;
| Element (tag,alist,l) ->
Buffer.add_char tmp '<';
Buffer.add_string tmp tag;
List.iter buffer_attr alist;
Buffer.add_char tmp '>';
pcdata := false;
List.iter loop l;
Buffer.add_string tmp "</";
Buffer.add_string tmp tag;
Buffer.add_char tmp '>';
pcdata := false;
| PCData text ->
if !pcdata then Buffer.add_char tmp ' ';
buffer_pcdata text;
pcdata := true;
in
Buffer.reset tmp;
loop x;
let s = Buffer.contents tmp in
Buffer.reset tmp;
s
let to_string_fmt x =
let rec loop ?(newl=false) tab = function
| Element (tag,alist,[]) ->
Buffer.add_string tmp tab;
Buffer.add_char tmp '<';
Buffer.add_string tmp tag;
List.iter buffer_attr alist;
Buffer.add_string tmp "/>";
if newl then Buffer.add_char tmp '\n';
| Element (tag,alist,[PCData text]) ->
Buffer.add_string tmp tab;
Buffer.add_char tmp '<';
Buffer.add_string tmp tag;
List.iter buffer_attr alist;
Buffer.add_string tmp ">";
buffer_pcdata text;
Buffer.add_string tmp "</";
Buffer.add_string tmp tag;
Buffer.add_char tmp '>';
if newl then Buffer.add_char tmp '\n';
| Element (tag,alist,l) ->
Buffer.add_string tmp tab;
Buffer.add_char tmp '<';
Buffer.add_string tmp tag;
List.iter buffer_attr alist;
Buffer.add_string tmp ">\n";
List.iter (loop ~newl:true (tab^" ")) l;
Buffer.add_string tmp tab;
Buffer.add_string tmp "</";
Buffer.add_string tmp tag;
Buffer.add_char tmp '>';
if newl then Buffer.add_char tmp '\n';
| PCData text ->
buffer_pcdata text;
if newl then Buffer.add_char tmp '\n';
in
Buffer.reset tmp;
loop "" x;
let s = Buffer.contents tmp in
Buffer.reset tmp;
s
|
