File: xml.ml

package info (click to toggle)
xml-light 2.4-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 212 kB
  • ctags: 352
  • sloc: ml: 1,691; makefile: 171
file content (268 lines) | stat: -rw-r--r-- 7,152 bytes parent folder | download | duplicates (5)
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
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
(*
 * 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 has the special exception on linking described in file
 * README.
 *
 * 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., 51 Franklin Street, Fifth Floor, Boston,
 * MA 02110-1301 USA
 *)

open Printf

type xml = 
	| Element of (string * (string * string) list * xml list)
	| PCData of string

type error_pos = {
	eline : int;
	eline_start : int;
	emin : int;
	emax : int;
}

type error_msg =
	| UnterminatedComment
	| UnterminatedString
	| UnterminatedEntity
	| IdentExpected
	| CloseExpected
	| NodeExpected
	| AttributeNameExpected
	| AttributeValueExpected
	| EndOfTagExpected of string
	| EOFExpected

type error = error_msg * error_pos

exception Error of error
exception File_not_found of string

exception Not_element of xml
exception Not_pcdata of xml
exception No_attribute of string

let default_parser = XmlParser.make()

let pos source =
	let line, lstart, min, max = Xml_lexer.pos source in
	{
		eline = line;
		eline_start = lstart;
		emin = min;
		emax = max;
	}

let parse (p:XmlParser.t) (source:XmlParser.source) =
	(* local cast Xml.xml -> xml *)
	(Obj.magic XmlParser.parse p source : xml)

let parse_in ch = parse default_parser (XmlParser.SChannel ch)
let parse_string str = parse default_parser (XmlParser.SString str)

let parse_file f =
	let p = XmlParser.make() in
	let path = Filename.dirname f in
	XmlParser.resolve p (fun file -> 
		let name = (match path with "." -> file | _ -> path ^ "/" ^ file) in
		Dtd.check (Dtd.parse_file name)
	);
	parse p (XmlParser.SFile f)

let error_msg = function
	| UnterminatedComment -> "Unterminated comment"
	| UnterminatedString -> "Unterminated string"
	| UnterminatedEntity -> "Unterminated entity"
	| IdentExpected -> "Ident expected"
	| CloseExpected -> "Element close expected"
	| NodeExpected -> "Xml node expected"
	| AttributeNameExpected -> "Attribute name expected"
	| AttributeValueExpected -> "Attribute value expected"
	| EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
	| EOFExpected -> "End of file expected"

let error (msg,pos) =
	if pos.emin = pos.emax then
		sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start)
	else
		sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
	
let line e = e.eline

let range e = 
	e.emin - e.eline_start , e.emax - e.eline_start

let abs_range e =
	e.emin , e.emax

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 "&lt;"
		| '&' ->
			if p < l-1 && text.[p+1] = '#' then
				Buffer.add_char tmp '&'
			else
				Buffer.add_string tmp "&amp;"
		| '\'' -> Buffer.add_string tmp "&apos;"
		| '"' -> Buffer.add_string tmp "&quot;"
		| c -> Buffer.add_char tmp 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 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

;;
XmlParser._raises (fun x p -> 
	(* local cast : Xml.error_msg -> error_msg *)
	Error ((Obj.magic x : error_msg),pos p))
	(fun f -> File_not_found f)
	(fun x p -> Dtd.Parse_error (x,
	(* local cast : Xml.error_pos -> error_pos *)
		(Obj.magic (pos p))));
Dtd._raises (fun f -> File_not_found f);