From d525103c8621f6ff0293311a8e8f9ac0c3580805 Mon Sep 17 00:00:00 2001
From: Richard Jones <rjones@trick.home.annexia.org>
Date: Wed, 30 Sep 2009 15:32:41 +0100
Subject: OCaml viewer: Use ocamlduce to replace xpath code.
---
ocaml/examples/LICENSE | 3 ++
ocaml/examples/Makefile.am | 6 ++--
ocaml/examples/viewer.ml | 57 ++++++++------------------------------
ocaml/examples/xmllight_loader.ml | 16 +++++++++++
ocaml/examples/xmllight_loader.mli | 2 ++
5 files changed, 36 insertions(+), 48 deletions(-)
create mode 100644 ocaml/examples/xmllight_loader.ml
create mode 100644 ocaml/examples/xmllight_loader.mli
diff --git a/ocaml/examples/LICENSE b/ocaml/examples/LICENSE
index 990daefc..78d360e7 100644
--- a/ocaml/examples/LICENSE
+++ b/ocaml/examples/LICENSE
@@ -4,3 +4,6 @@ copied without any restrictions.
The files 'Throbber.png' and 'Throbber.gif' come from the source to
Firefox, and you should check the Firefox license before
redistributing those files.
+
+The files 'xmllight_loader.ml' and 'xmllight_loader.mli' come from
+http://yquem.inria.fr/~frisch/ocamlcduce/samples/xmllight/
diff --git a/ocaml/examples/Makefile.am b/ocaml/examples/Makefile.am
index d088c4a9..b516647d 100644
--- a/ocaml/examples/Makefile.am
+++ b/ocaml/examples/Makefile.am
@@ -13,11 +13,11 @@ if BUILD_OCAML_VIEWER
noinst_SCRIPTS += viewer
-viewer: throbber.ml viewer.ml
- $(OCAMLFIND) ocamlopt \
+viewer: throbber.ml xmllight_loader.mli xmllight_loader.ml viewer.ml
+ ocamlducefind opt \
-warn-error A \
-thread \
- -package libvirt,lablgtk2,extlib,xml-light,threads -I .. \
+ -package libvirt,lablgtk2,extlib,xml-light,ocamlduce,threads -I .. \
-predicates init,threads \
-linkpkg mlguestfs.cmxa gtkThread.cmx \
$^ -o $@
diff --git a/ocaml/examples/viewer.ml b/ocaml/examples/viewer.ml
index ef6627b1..eeff5252 100644
--- a/ocaml/examples/viewer.ml
+++ b/ocaml/examples/viewer.ml
@@ -10,6 +10,7 @@
* - extlib (http://code.google.com/p/ocaml-extlib/)
* - lablgtk2 (http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html
* - xml-light (http://tech.motion-twin.com/xmllight.html)
+ * - cduce and ocamlduce (http://cduce.org/)
* - ocaml-libvirt (http://libvirt.org/ocaml)
* - ocaml-libguestfs
*
@@ -314,52 +315,18 @@ end = struct
(match !dom with Some dom -> D.free dom | None -> ());
dom := None
- (* This would be much simpler if OCaml had either a decent XPath
- * implementation, or if ocamlduce was stable enough that we
- * could rely on it being available. So this is *not* an example
- * of either good OCaml or good programming. XXX
- *)
and get_devices_from_xml xml =
- let xml = Xml.parse_string xml in
- let devices =
- match xml with
- | Xml.Element ("domain", _, children) ->
- let devices =
- List.filter_map (
- function
- | Xml.Element ("devices", _, devices) -> Some devices
- | _ -> None
- ) children in
- List.concat devices
- | _ ->
- failwith "get_xml_desc didn't return <domain/>" in
- let rec source_dev_of = function
- | [] -> None
- | Xml.Element ("source", attrs, _) :: rest ->
- (try Some (List.assoc "dev" attrs)
- with Not_found -> source_dev_of rest)
- | _ :: rest -> source_dev_of rest
- in
- let rec source_file_of = function
- | [] -> None
- | Xml.Element ("source", attrs, _) :: rest ->
- (try Some (List.assoc "file" attrs)
- with Not_found -> source_file_of rest)
- | _ :: rest -> source_file_of rest
- in
- let devs =
- List.filter_map (
- function
- | Xml.Element ("disk", _, children) -> source_dev_of children
- | _ -> None
- ) devices in
- let files =
- List.filter_map (
- function
- | Xml.Element ("disk", _, children) -> source_file_of children
- | _ -> None
- ) devices in
- devs @ files
+ (* Lengthy discussion of the merits or otherwise of this code here:
+ * http://groups.google.com/group/fa.caml/browse_thread/thread/48e05d49b0f21b8a/5296bceb31ebfff3
+ *)
+ let xml = Xmllight_loader.from_string xml in
+ let xs = {{ [xml] }} in
+ let xs = {{ (((xs.(<domain..>_)) / .(<devices..>_)) / .(<disk..>_)) / }} in
+ let xs = {{ map xs with
+ | <source dev=(Latin1 & s) ..>_
+ | <source file=(Latin1 & s) ..>_ -> [s]
+ | _ -> [] }} in
+ {: xs :}
end
(* End of slave thread code. *)
(*----------------------------------------------------------------------*)
diff --git a/ocaml/examples/xmllight_loader.ml b/ocaml/examples/xmllight_loader.ml
new file mode 100644
index 00000000..46dd77f7
--- /dev/null
+++ b/ocaml/examples/xmllight_loader.ml
@@ -0,0 +1,16 @@
+open Xml
+open Ocamlduce.Load
+
+
+let from_xml ?ns xml =
+ let l = make ?ns () in
+ let rec aux = function
+ | Element (tag, attrs, child) ->
+ start_elem l tag attrs; List.iter aux child; end_elem l ()
+ | PCData s ->
+ text l s in
+ aux xml;
+ get l
+
+let from_file ?ns s = from_xml ?ns (parse_file s)
+let from_string ?ns s = from_xml ?ns (parse_string s)
diff --git a/ocaml/examples/xmllight_loader.mli b/ocaml/examples/xmllight_loader.mli
new file mode 100644
index 00000000..6c7bbe97
--- /dev/null
+++ b/ocaml/examples/xmllight_loader.mli
@@ -0,0 +1,2 @@
+val from_file : ?ns:bool -> string -> Ocamlduce.Load.anyxml
+val from_string : ?ns:bool -> string -> Ocamlduce.Load.anyxml
--
cgit