1 (* Copyright (C) 2000-2002, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
26 let prerr_endline _ = ();;
28 let mathmlns = "http://www.w3.org/1998/Math/MathML";;
29 let xmldiffns = "http://helm.cs.unibo.it/XmlDiff";;
31 let highlight_node (doc: Gdome.document) (n: Gdome.node) =
32 let highlight (n: Gdome.node) =
35 ~namespaceURI:(Some (Gdome.domString mathmlns))
36 ~qualifiedName:(Gdome.domString "m:mstyle")
38 highlighter#setAttribute ~name:(Gdome.domString "background")
39 ~value:(Gdome.domString "yellow") ;
40 highlighter#setAttributeNS
41 ~namespaceURI:(Some (Gdome.domString xmldiffns))
42 ~qualifiedName:(Gdome.domString "xmldiff:type")
43 ~value:(Gdome.domString "fake") ;
45 match n#get_parentNode with
49 ignore (highlighter#appendChild n) ;
50 ignore (parent#appendChild (highlighter :> Gdome.node))
52 let rec find_mstylable_node n =
53 match n#get_namespaceURI, n#get_localName with
55 nu#to_string = mathmlns &&
56 let ln = ln#to_string in
57 ln <> "mtr" && ln <> "mtd" -> n
58 | Some nu, Some ln when
59 nu#to_string = mathmlns &&
60 let ln = ln#to_string in
61 ln = "mtr" || ln = "mtd" ->
62 prerr_endline "@@@ find_mstylable_node scendo";
64 match n#get_firstChild with
68 find_mstylable_node true_child
70 prerr_endline ("@@@ find_mstylable_node salgo da " ^ match n#get_localName with Some n -> n#to_string | None -> "_") ;
71 match n#get_parentNode with
73 | Some p -> find_mstylable_node p
75 highlight (find_mstylable_node n)
78 let update_dom ~(from : Gdome.document) (d : Gdome.document) =
79 let rec aux (p: Gdome.node) (f: Gdome.node) (t: Gdome.node) =
80 (* Perche' non andava?
81 if f#get_localName = t#get_localName &&
82 f#get_namespaceURI = t#get_namespaceURI
85 f#get_nodeType,t#get_nodeType,
86 f#get_namespaceURI,t#get_namespaceURI,
87 f#get_localName,t#get_localName
89 GdomeNodeTypeT.TEXT_NODE,GdomeNodeTypeT.TEXT_NODE,_,_,_,_ when
90 match f#get_nodeValue, t#get_nodeValue with
91 Some v, Some v' -> v#to_string = v'#to_string
94 prerr_endline ("XML_DIFF: preservo il nodo testo " ^ match f#get_nodeValue with Some v -> v#to_string | None -> assert false);
96 | GdomeNodeTypeT.ELEMENT_NODE,GdomeNodeTypeT.ELEMENT_NODE,
97 Some nu, Some nu', Some ln, Some ln' when
98 ln#to_string = ln'#to_string && nu#to_string = nu'#to_string ->
99 prerr_endline ("XML_DIFF: preservo il nodo "^ nu#to_string ^ ":" ^ln#to_string);
101 match f#get_attributes, t#get_attributes with
102 Some fattrs, Some tattrs ->
103 let flen = fattrs#get_length in
104 let tlen = tattrs#get_length in
105 let processed = ref [] in
106 for i = 0 to flen -1 do
107 match fattrs#item i with
108 None -> () (* CSC: sigh, togliere un nodo rompe fa decrescere la lunghezza ==> passare a un while *)
110 match attr#get_namespaceURI with
112 (* Back to DOM Level 1 ;-( *)
114 let name = attr#get_nodeName in
115 match tattrs#getNamedItem ~name with
117 prerr_endline ("XML_DIFF: DOM 1; rimuovo l'attributo " ^ name#to_string);
118 (* CSC: questo non mi toglieva solo l'attributo, ma anche altri nodi qui
120 ignore (f#removeChild attr)
122 ignore (fattrs#removeNamedItem ~name)
125 (None,Some name)::!processed ;
126 match attr#get_nodeValue, attr'#get_nodeValue with
127 Some v1, Some v2 when
128 v1#to_string = v2#to_string
129 || (name#to_string = "selection" &&
131 "http://www.w3.org/1998/Math/MathML" &&
132 ln#to_string = "maction")
134 prerr_endline ("XML_DIFF: DOM 1; preservo l'attributo " ^ name#to_string);
136 | Some v1, Some v2 ->
137 prerr_endline ("XML_DIFF: DOM 1; rimpiazzo l'attributo " ^ name#to_string ^ ": old value=" ^ v1#to_string ^ ", new value=" ^ v2#to_string);
138 let attr'' = from#importNode attr' true in
139 ignore (fattrs#setNamedItem attr'')
140 | _,_ -> assert false
142 | Some namespaceURI ->
144 match attr#get_localName with
146 | None -> assert false
149 tattrs#getNamedItemNS ~namespaceURI ~localName
152 prerr_endline ("XML_DIFF: DOM 2; rimuovo l'attributo " ^ namespaceURI#to_string ^ ":" ^ localName#to_string);
153 (* CSC: questo non mi toglieva solo l'attributo, ma anche altri nodi qui
155 ignore (f#removeChild attr)
158 (fattrs#removeNamedItemNS
159 ~namespaceURI ~localName)
162 (Some namespaceURI,Some localName)::!processed ;
163 (*CSC: questo mi dice read-only ;-(
164 attr#set_nodeValue attr'#get_nodeValue *)
165 (*CSC: questo mi abortisce con una assert
166 let attr'' = from#importNode attr' true in
167 ignore(f#replaceChild ~newChild:attr'' ~oldChild:attr)*)
168 match attr#get_nodeValue, attr'#get_nodeValue with
169 Some v1, Some v2 when
170 v1#to_string = v2#to_string ->
171 prerr_endline ("XML_DIFF: DOM 2; preservo l'attributo " ^ namespaceURI#to_string ^ ":" ^ localName#to_string);
174 prerr_endline ("XML_DIFF: DOM 2; rimpiazzo l'attributo " ^ namespaceURI#to_string ^ ":" ^ localName#to_string);
175 let attr'' = from#importNode attr' true in
176 ignore (fattrs#setNamedItem attr'')
177 | _,_ -> assert false
179 for i = 0 to tlen -1 do
180 match tattrs#item i with
183 let debugs = ref "" in
184 let namespaceURI,localName =
185 match attr#get_namespaceURI with
187 debugs := ("XML_DIFF: DOM 1; creo un nuovo attributo " ^ attr#get_nodeName#to_string) ;
188 None,attr#get_nodeName
189 | Some namespaceURI as v ->
190 debugs := ("XML_DIFF: DOM 2; creo un nuovo attributo " ^ namespaceURI#to_string ^ ":" ^ match attr#get_localName with Some v -> v#to_string | None -> assert false);
191 v, match attr#get_localName with
199 None,Some localName' ->
200 (match namespaceURI with
202 localName#to_string = localName'#to_string
204 | Some namespaceURI', Some localName' ->
205 (match namespaceURI with
207 | Some namespaceURI ->
208 localName#to_string = localName'#to_string &&
209 namespaceURI#to_string=namespaceURI'#to_string
211 | _,_ -> assert false
214 let attr' = from#importNode attr false in
215 prerr_endline !debugs ;
216 ignore (fattrs#setNamedItem attr')
218 | _,_ -> assert false
220 let fchildren = f#get_childNodes in
221 let tchildren = t#get_childNodes in
225 | he1::tl1,he2::tl2 ->
226 prerr_endline "XML_DIFF: processo una coppia di figli" ;
230 prerr_endline ("XML_DIFF: appendo i nodi residui " ^ String.concat ", " (List.map (function n -> match n#get_localName with Some s -> s#to_string | None -> "#" ^ (match n#get_nodeValue with Some s -> s#to_string | None -> "_") ^ "#") tl2)) ;
233 let n' = from#importNode n true in
234 ignore (f#appendChild n') ;
235 highlight_node from n'
238 prerr_endline ("XML_DIFF: cancello i nodi residui " ^ String.concat ", " (List.map (function n -> match n#get_localName with Some s -> s#to_string | None -> "_") tl1)) ;
239 List.iter (function n -> ignore (f#removeChild n)) tl1
241 let node_list_of_nodeList nl =
243 match nl#item ~index:i with
246 n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE
247 or n#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
250 prerr_endline ("XML_DIFF: mi sto perdendo i nodi di tipo " ^ string_of_int (Obj.magic n#get_nodeType)) ;
255 for i = 0 to fchildren#get_length - 1 do
256 match fchildren#item i with
257 None -> prerr_endline "EUREKA: ma siamo matti?"
259 match n#get_nodeType with GdomeNodeTypeT.ATTRIBUTE_NODE -> prerr_endline "EUREKA attr" | GdomeNodeTypeT.CDATA_SECTION_NODE -> prerr_endline "EUREKA text" | GdomeNodeTypeT.DOCUMENT_FRAGMENT_NODE -> prerr_endline "EUREKA document fragment" | _ -> prerr_endline ("EUREKA " ^ string_of_int (Obj.magic n#get_nodeType))
261 prerr_endline("XML_DIFF: from ha " ^ string_of_int fchildren#get_length ^ " nodi, ovvero " ^ string_of_int (List.length (node_list_of_nodeList fchildren)) ^ " figli");
262 prerr_endline("XML_DIFF: to ha " ^ string_of_int tchildren#get_length ^ " nodi, ovvero " ^ string_of_int (List.length (node_list_of_nodeList tchildren)) ^ " figli");
263 prerr_endline ("XML_DIFF: chiamo dumb_diff su " ^ String.concat ", " (List.map (function n -> match n#get_localName with Some s -> s#to_string | None -> "_") (node_list_of_nodeList fchildren)) ^ " e " ^ String.concat ", " (List.map (function n -> match n#get_localName with Some s -> s#to_string | None -> "_") (node_list_of_nodeList tchildren))) ;
265 (node_list_of_nodeList fchildren, node_list_of_nodeList tchildren)
267 (t1 = GdomeNodeTypeT.ELEMENT_NODE || t1 = GdomeNodeTypeT.TEXT_NODE) &&
268 (t2 = GdomeNodeTypeT.ELEMENT_NODE || t2 = GdomeNodeTypeT.TEXT_NODE) ->
270 t1 = GdomeNodeTypeT.ELEMENT_NODE &&
271 ((new Gdome.element_of_node f)#getAttributeNS
272 ~namespaceURI:(Gdome.domString xmldiffns)
273 ~localName:(Gdome.domString "type"))#to_string = "fake"
276 match f#get_firstChild with
281 prerr_endline ("%%% CANCELLO HIGHLIGHTER " ^ (match f#get_localName with Some s -> s#to_string | None -> "_") ^ " CON DENTRO " ^ (match true_child#get_localName with Some s -> s#to_string | None -> "_")) ;
282 (********* PROVE E RIPROVE
283 let old_true_child = true_child in
285 (from#createElementNS
286 ~namespaceURI:(Some (Gdome.domString mathmlns))
287 ~qualifiedName:(Gdome.domString "m:mrow") :> Gdome.node) ;
289 ignore (f#removeChild old_true_child) ;
290 ignore (true_child#appendChild old_true_child) ;
291 ignore (p#replaceChild ~oldChild:f ~newChild:true_child) ;
293 ignore (true_child#appendChild old_true_child) ;
294 ignore (p#replaceChild ~oldChild:f ~newChild:true_child) ;
296 prerr_endline ("%%% RICORSIONE SU " ^ (match true_child#get_localName with Some s -> s#to_string | None -> "_") ^ "/" ^ (match old_true_child#get_localName with Some s -> s#to_string | None -> "_") ^ " E " ^ (match old_true_child#get_localName with Some s -> s#to_string | None -> "_")) ;
297 let fchildren = old_true_child#get_childNodes in
299 for i = 0 to fchildren#get_length -1 do
300 l := !l @ [ match (fchildren#item i) with None -> "?" | Some n -> match n#get_localName with Some s -> s#to_string | None -> "_" ]
302 let tchildren = t#get_childNodes in
304 for i = 0 to tchildren#get_length -1 do
305 l2 := !l2 @ [ match (tchildren#item i) with None -> "?" | Some n -> match n#get_localName with Some s -> s#to_string | None -> "_" ]
307 prerr_endline ("%%% Il primo nodo ha i seguenti figli: " ^ String.concat "," !l) ;
308 prerr_endline ("%%% Il secondo nodo ha i seguenti figli: " ^ String.concat "," !l2) ;
310 let fchildren = old_true_child#get_childNodes in
311 let tchildren = t#get_childNodes in
312 let node_list_of_nodeList nl =
314 match nl#item ~index:i with
317 n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE
318 or n#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
321 prerr_endline ("### XML_DIFF: mi sto perdendo i nodi di tipo " ^ string_of_int (Obj.magic n#get_nodeType)) ;
326 prerr_endline ("RRR XML_DIFF: chiamo dumb_diff su " ^ String.concat ", " (List.map (function n -> match n#get_localName with Some s -> s#to_string | None -> "_") (node_list_of_nodeList fchildren)) ^ " e " ^ String.concat ", " (List.map (function n -> match n#get_localName with Some s -> s#to_string | None -> "_") (node_list_of_nodeList tchildren))) ;
327 aux true_child old_true_child t
332 ignore (p#replaceChild ~oldChild:f ~newChild:true_child) ;
336 let t' = from#importNode t true in
337 prerr_endline ("%%% XML_DIFF: importo il nodo " ^ match t'#get_localName with Some n -> n#to_string | None -> "_") ;
339 prerr_endline ("Rimpiazzo" ^ (match f#get_namespaceURI with Some s -> s#to_string) ^ ":" ^ (match f#get_localName with Some s -> s#to_string) ^ " con " ^ (match t#get_namespaceURI with Some s -> s#to_string) ^ ":" ^ (match t#get_localName with Some s -> s#to_string) ^ " in " ^ (match p#get_localName with Some s -> s#to_string | None -> "_")) ;
341 ignore (p#replaceChild ~newChild:t' ~oldChild:f) ;
342 highlight_node from t'
343 | _,_,_,_,_,_ -> assert false
346 aux (d :> Gdome.node)
347 (from#get_documentElement :> Gdome.node)
348 (d#get_documentElement :> Gdome.node)
350 (GdomeInit.DOMException (e,msg) as ex) ->
352 let module E = GdomeDOMExceptionT in
355 ("DOM EXCEPTION: " ^ msg ^ " --- " ^
356 string_of_int (Obj.magic e)) ;
361 | E.INDEX_SIZE_ERR -> "INDEX_SIZE_ERR"
362 | E.DOMSTRING_SIZE_ERR -> "DOMSTRING_SIZE_ERR"
363 | E.HIERARCHY_REQUEST_ERR -> "HIERARCHY_REQUEST_ERR"
364 | E.WRONG_DOCUMENT_ERR -> "WRONG_DOCUMENT_ERR"
365 | E.INVALID_CHARACTER_ERR -> "INVALID_CHARACTER_ERR"
366 | E.NO_DATA_ALLOWED_ERR -> "NO_DATA_ALLOWER_ERR"
367 | E.NO_MODIFICATION_ALLOWED_ERR -> "NO_MODIFICATION_ALLOWED_ERR"
368 | E.NOT_FOUND_ERR -> "NOT_FOUND_ERR"
369 | E.NOT_SUPPORTED_ERR -> "NOT_SUPPORTED_ERR"
370 | E.INUSE_ATTRIBUTE_ERR -> "INUSE_ATTRIBUTE_ERR"
371 | E.INVALID_STATE_ERR -> "INVALID_STATE_ERR"
372 | E.SYNTAX_ERR -> "SYNTAX_ERR"
373 | E.INVALID_MODIFICATION_ERR -> "INVALID_MODIFICATION_ERR"
374 | E.NAMESPACE_ERR -> "NAMESPACE_ERR"
375 | E.INVALID_ACCESS_ERR -> "INVALID_ACCESS_ERR"
378 prerr_endline "PROBLEMA" ;