Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 284 lines (253 sloc) 8.888 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
19 #<Debugvar:DEBUG_XML>
20
fccc685 Initial open-source release
MLstate authored
21 module List = BaseList
22
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
23 (* -- *)
24
25 let debug fmt =
26 #<If> Printf.eprintf ("[Xml]"^^fmt)
27 #<Else> Printf.ifprintf stdout fmt
28 #<End>
29
fccc685 Initial open-source release
MLstate authored
30
31 (* FIXME: unifier avec Qml *)
32 type value =
33 | Value of string
34 (* FIXME: remettre ??? | Func of string * value list *)
35 (* string * string list (* parameters *) *)
36 ;;
37
38 type parameters = value StringMap.t (* name *) (* FIXME: stringmap (* ns *) *)
39 ;;
40 type nid = int
41 ;;
42 type node =
43 { nns : string option
44 ; nname : string
45 ; npars : parameters
46 ; ncontent : content list
47 ; nparent : int
48 }
49 and content =
50 | Text of string
51 | Node of nid
52 ;;
53
54 type xml =
55 { header : (string * value) list (* parameters *)
56 ; count : int
57 ; main : int list
58 ; nodes : node IntMap.t (* nidmap *) }
59 ;;
60
61 let empty_xml =
62 { header = []
63 ; count = 0
64 ; main = []
65 ; nodes = IntMap.empty
66 }
67 ;;
68
69 let add_node node elt = { node with ncontent = (elt :: node.ncontent) }
70
71 let new_node n o =
72 { nns = None
73 ; nname = n
74 ; npars = StringMap.from_list o
75 ; ncontent = []
76 ; nparent = -1
77 }
78
79 let rewrite l =
80 let rec aux ok stack xml = function
81 | `one ((n, _) as t) :: tl -> aux ok stack xml (`start t :: `stop n :: tl)
82 | `start (n, o) :: tl ->
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
83 debug "start: %s" n;
fccc685 Initial open-source release
MLstate authored
84 let nid = xml.count
85 and node = new_node n o in
86 let stack, is_main = match stack with
87 | (snid, snode) :: stl ->
88 (nid, { node with nparent = snid }) ::
89 (snid, add_node snode (Node nid)) :: stl, false
90 | _ ->
91 [nid, node], true
92 in
93 let xml = if is_main then { xml with main = nid :: xml.main } else xml in
94 aux ok stack { xml with count = succ nid } tl
95 | `stop n :: tl ->
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
96 debug "stop: %s" n;
fccc685 Initial open-source release
MLstate authored
97 begin match stack with
98 | (nid, node) :: stl ->
99 if node.nname = n then
100 let node = { node with ncontent = List.rev node.ncontent } in
101 aux ok stl { xml with nodes = IntMap.add nid node xml.nodes } tl
102 else (
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
103 debug "error in rewrite: closing tag %s which is not last open tag" n;
fccc685 Initial open-source release
MLstate authored
104 aux false stack xml tl
105 )
106 | _ ->
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
107 debug "error in rewrite: closing tag %s which is not open" n;
fccc685 Initial open-source release
MLstate authored
108 aux false stack xml tl
109 end
110 | `text t :: tl ->
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
111 debug "text: %s" t;
fccc685 Initial open-source release
MLstate authored
112 begin match stack with
113 | (nid, node) :: stl ->
114 let node = add_node node (Text t) in
115 aux ok ((nid, node)::stl) xml tl
116 | _ ->
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
117 debug "error in rewrite: text '%s' outside of tag (skipped)" t;
fccc685 Initial open-source release
MLstate authored
118 aux false stack xml tl
119 end
120 | `space :: tl ->
121 let l = if stack=[] then tl else (`text " " :: tl) in
122 aux ok stack xml l
123 | _ ->
124 if stack=[] then { xml with main = List.rev xml.main }, ok
125 else
126 let id = fst (List.hd stack) in
127 let name = (snd (List.hd stack)).nname in
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
128 debug "error in rewrite: tag <%d:%s> is never closed" id name;
fccc685 Initial open-source release
MLstate authored
129 aux false stack xml [`stop name]
130 in
131 aux true [] empty_xml l
132
133 let print_options m =
134 StringMap.fold (
135 fun x (Value y) acc ->
136 acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped y)
137 ) m ""
138
139 let print_header m =
140 List.fold_left (
141 fun acc (x, Value y) ->
142 acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped y)
143 ) "" m
144
145 (** print options and apply a function to each element
146 -> utilisé par exemple pour remplacer
147 action: par javascript: dans les lients *)
148 let print_options_f f m =
149 StringMap.fold (
150 fun x (Value y) acc ->
151 acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped (f x y))
152 ) m ""
153
154 let fold f1 f2 init xml =
155 let rec aux ~path acc nid =
156 let path = nid :: path in
157 let node = IntMap.find nid xml.nodes in
158 let acc = f1 acc node.nname node.npars in
159 List.fold_left (
160 fun acc x -> match x with
161 | Text t -> f2 acc path t
162 | Node n -> aux ~path acc n
163 ) acc node.ncontent
164 in
165 List.fold_left (aux ~path:[]) init xml.main
166
167
168 (* List.map ( *)
169 (* fun x -> match x with *)
170 (* | Text t -> f node.nname node.npars t *)
171 (* | n -> n *)
172 (* ) node.ncontent *)
173 let change_content f node =
174 let rec aux acc_content acc_nodes = function
175 | (Text t) :: tl ->
176 let items, delete, insert = f node.nname node.npars t in
177 let acc_nodes = insert @ acc_nodes in
178 if delete then None, acc_nodes
179 else aux (items @ acc_content) acc_nodes (* FIXME: check rev *) tl
180 | n :: tl -> aux (n :: acc_content) acc_nodes tl
181 | _ -> Some (List.rev acc_content), acc_nodes
182 in aux [] [] node.ncontent
183
184 let delete_node ?(replace=[]) xml parent nid =
185 match parent with
186 | None -> { xml with main = List.remove_all nid xml.main }
187 | Some p ->
188 let parent_node = IntMap.find p xml.nodes in
189 let parent_content = List.replace (Node nid) (List.map (fun x -> Node x) replace) parent_node.ncontent in
190 { xml with nodes = IntMap.add p { parent_node with ncontent = parent_content } xml.nodes }
191
192 let insert_node parent (xml, nid_list) (n, o, content) =
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
193 debug "insert_node" ;
fccc685 Initial open-source release
MLstate authored
194 let nid = xml.count
195 and node = new_node n o in
196 let node =
197 { node with
198 nparent = (match parent with Some p -> p | _ -> -1)
199 ; ncontent = content } in
200 { xml with nodes = IntMap.add nid node xml.nodes ; count = succ xml.count },
201 nid :: nid_list
202
203 (** map sur le texte des noeuds Xml *)
204 (* FIXME: rename *)
205 let map f xml =
206 let rec aux parent xml nid =
207 let node = IntMap.find nid xml.nodes in
208
209 match change_content f node with
210 | Some ncontent, _insert ->
211 (* nouveau contenu de la node *)
212 let xml =
213 { xml with nodes =
214 IntMap.add nid { node with ncontent = ncontent } xml.nodes }
215 (* liste des nid à modifier *)
216 and next = List.fold_left (
217 fun acc x -> match x with
218 | Node n -> n :: acc
219 | _ -> acc
220 ) [] node.ncontent
221 in
222 List.fold_left (aux (Some nid)) xml next
223 | _, insert ->
224 let xml, nid_list = List.fold_left (insert_node parent) (xml, []) insert in
225 delete_node xml parent nid ~replace:nid_list
226 in
227 List.fold_left (aux None) xml xml.main
228
229 let print ?(header=false) ?(pretty=false) xml =
230 let nl = if pretty then "\n" else "" in
231 let rec aux b nid =
232 let node = IntMap.find nid xml.nodes in
233 let b = FBuffer.add b (Printf.sprintf "<%s%s>%s" node.nname (print_options node.npars) nl) in
234 let b = List.fold_left (
235 fun acc x -> match x with
236 | Text t -> FBuffer.add acc t
237 | Node n -> aux acc n
238 ) b node.ncontent in
239 FBuffer.add b (Printf.sprintf "</%s>%s" node.nname nl)
240 in
241 let b = FBuffer.make ~name:"Xml.print" 256 in
242 let b =
243 if header then
244 FBuffer.add b (Printf.sprintf "<?xml%s ?>%s" (print_header xml.header) nl)
245 else b in
246 FBuffer.contents (List.fold_left aux b xml.main)
247
248 (** construit un stringmap: id -> nid pour un xml
249 retourne également un booléen FAUX si les ids sont correctes, VRAI si une id est redéfinie
250 *)
251 let build_ids ?(tag="id") xml =
252 IntMap.fold (
253 fun id node (acc, err) ->
254 if StringMap.mem tag node.npars then
255 let (Value value) = StringMap.find tag node.npars in
256 StringMap.add value id acc,
257 (StringMap.mem value acc)
258 (* Base.warning_if_true (StringMap.mem value acc) *)
259 (* (Printf.sprintf "id %s is defined several times" value) *)
260 or err
261 else (acc, err)
262 ) xml.nodes (StringMap.empty, false)
263
264 (** construit un stringmap: class -> nid list (classée par position décroissante) pour un xml *)
265 let build_classes ?(tag="class") xml =
266 IntMap.fold (
267 fun id node acc ->
268 if StringMap.mem tag node.npars then
269 let (Value value) = StringMap.find tag node.npars in
270 let list = if StringMap.mem value acc then StringMap.find value acc else [] in
271 StringMap.add value (id::list) acc
272 else acc
273 ) xml.nodes StringMap.empty
274
275 (** liste (id, tag)* des parents du noeud nid *)
276 let tag_path xml nid =
277 let rec aux path id =
278 if id = 0 then path
279 else
280 let node = IntMap.find id xml.nodes in
281 aux ((node.nparent, node.nname)::path) node.nparent
282 in
283 aux [] nid
Something went wrong with that request. Please try again.