# HG changeset patch
# User Keir Fraser <keir.fraser@xxxxxxxxxx>
# Date 1273218411 -3600
# Node ID b36273f2fbc84ef3075a241993ccc41d61f0fd36
# Parent 30f6827de7057c0c7c61b9a93c24fc5404a47a6a
ocam: add missing files that got lost in the v2 shuffle
Signed-off-by: Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
---
tools/ocaml/xenstored/stdext.ml | 130 ++++++++++++++++++++++++++++
tools/ocaml/xenstored/trie.ml | 182 ++++++++++++++++++++++++++++++++++++++++
tools/ocaml/xenstored/trie.mli | 60 +++++++++++++
3 files changed, 372 insertions(+)
diff -r 30f6827de705 -r b36273f2fbc8 tools/ocaml/xenstored/stdext.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/stdext.ml Fri May 07 08:46:51 2010 +0100
@@ -0,0 +1,130 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008-2010 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ * Author Dave Scott <dave.scott@xxxxxxxxxxxxx>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program 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.
+ *)
+
+type ('a, 'b) either = Right of 'a | Left of 'b
+
+(** apply the clean_f function after fct function has been called.
+ * Even if fct raises an exception, clean_f is applied
+ *)
+let exnhook = ref None
+
+let finally fct clean_f =
+ let result = try
+ fct ();
+ with
+ exn ->
+ (match !exnhook with None -> () | Some f -> f exn);
+ clean_f (); raise exn in
+ clean_f ();
+ result
+
+(** if v is not none, apply f on it and return some value else return none. *)
+let may f v =
+ match v with Some x -> Some (f x) | None -> None
+
+(** default value to d if v is none. *)
+let default d v =
+ match v with Some x -> x | None -> d
+
+(** apply f on v if not none *)
+let maybe f v =
+ match v with None -> () | Some x -> f x
+
+module String = struct include String
+
+let of_char c = String.make 1 c
+
+let rec split ?limit:(limit=(-1)) c s =
+ let i = try String.index s c with Not_found -> -1 in
+ let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in
+ if i = -1 || nlimit = 0 then
+ [ s ]
+ else
+ let a = String.sub s 0 i
+ and b = String.sub s (i + 1) (String.length s - i - 1) in
+ a :: (split ~limit: nlimit c b)
+
+let fold_left f accu string =
+ let accu = ref accu in
+ for i = 0 to length string - 1 do
+ accu := f !accu string.[i]
+ done;
+ !accu
+
+(** True if string 'x' starts with prefix 'prefix' *)
+let startswith prefix x =
+ let x_l = String.length x and prefix_l = String.length prefix in
+ prefix_l <= x_l && String.sub x 0 prefix_l = prefix
+end
+
+module Unixext = struct
+
+(** remove a file, but doesn't raise an exception if the file is already
removed *)
+let unlink_safe file =
+ try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _
-> ()
+
+(** create a directory but doesn't raise an exception if the directory already
exist *)
+let mkdir_safe dir perm =
+ try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
+
+(** create a directory, and create parent if doesn't exist *)
+let mkdir_rec dir perm =
+ let rec p_mkdir dir =
+ let p_name = Filename.dirname dir in
+ if p_name <> "/" && p_name <> "."
+ then p_mkdir p_name;
+ mkdir_safe dir perm in
+ p_mkdir dir
+
+(** daemonize a process *)
+(* !! Must call this before spawning any threads !! *)
+let daemonize () =
+ match Unix.fork () with
+ | 0 ->
+ if Unix.setsid () == -1 then
+ failwith "Unix.setsid failed";
+
+ begin match Unix.fork () with
+ | 0 ->
+ let nullfd = Unix.openfile "/dev/null" [ Unix.O_WRONLY
] 0 in
+ begin try
+ Unix.close Unix.stdin;
+ Unix.dup2 nullfd Unix.stdout;
+ Unix.dup2 nullfd Unix.stderr;
+ with exn -> Unix.close nullfd; raise exn
+ end;
+ Unix.close nullfd
+ | _ -> exit 0
+ end
+ | _ -> exit 0
+
+(** write a pidfile file *)
+let pidfile_write filename =
+ let fd = Unix.openfile filename
+ [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ]
+ 0o640 in
+ finally
+ (fun () ->
+ let pid = Unix.getpid () in
+ let buf = string_of_int pid ^ "\n" in
+ let len = String.length buf in
+ if Unix.write fd buf 0 len <> len
+ then failwith "pidfile_write failed";
+ )
+ (fun () -> Unix.close fd)
+
+end
diff -r 30f6827de705 -r b36273f2fbc8 tools/ocaml/xenstored/trie.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/trie.ml Fri May 07 08:46:51 2010 +0100
@@ -0,0 +1,182 @@
+(*
+ * Copyright (C) 2008-2009 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxxxxx>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program 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.
+ *)
+
+module Node =
+struct
+ type ('a,'b) t = {
+ key: 'a;
+ value: 'b option;
+ children: ('a,'b) t list;
+ }
+
+ let create key value = {
+ key = key;
+ value = Some value;
+ children = [];
+ }
+
+ let empty key = {
+ key = key;
+ value = None;
+ children = []
+ }
+
+ let get_key node = node.key
+ let get_value node =
+ match node.value with
+ | None -> raise Not_found
+ | Some value -> value
+
+ let get_children node = node.children
+
+ let set_value node value =
+ { node with value = Some value }
+ let set_children node children =
+ { node with children = children }
+
+ let add_child node child =
+ { node with children = child :: node.children }
+end
+
+type ('a,'b) t = ('a,'b) Node.t list
+
+let mem_node nodes key =
+ List.exists (fun n -> n.Node.key = key) nodes
+
+let find_node nodes key =
+ List.find (fun n -> n.Node.key = key) nodes
+
+let replace_node nodes key node =
+ let rec aux = function
+ | [] -> []
+ | h :: tl when h.Node.key = key -> node :: tl
+ | h :: tl -> h :: aux tl
+ in
+ aux nodes
+
+let remove_node nodes key =
+ let rec aux = function
+ | [] -> raise Not_found
+ | h :: tl when h.Node.key = key -> tl
+ | h :: tl -> h :: aux tl
+ in
+ aux nodes
+
+let create () = []
+
+let rec iter f tree =
+ let rec aux node =
+ f node.Node.key node.Node.value;
+ iter f node.Node.children
+ in
+ List.iter aux tree
+
+let rec map f tree =
+ let rec aux node =
+ let value =
+ match node.Node.value with
+ | None -> None
+ | Some value -> f value
+ in
+ { node with Node.value = value; Node.children = map f
node.Node.children }
+ in
+ List.filter (fun n -> n.Node.value <> None || n.Node.children <> [])
(List.map aux tree)
+
+let rec fold f tree acc =
+ let rec aux accu node =
+ fold f node.Node.children (f node.Node.key node.Node.value accu)
+ in
+ List.fold_left aux acc tree
+
+(* return a sub-trie *)
+let rec sub_node tree = function
+ | [] -> raise Not_found
+ | h::t ->
+ if mem_node tree h
+ then begin
+ let node = find_node tree h in
+ if t = []
+ then node
+ else sub_node node.Node.children t
+ end else
+ raise Not_found
+
+let sub tree path =
+ try (sub_node tree path).Node.children
+ with Not_found -> []
+
+let find tree path =
+ Node.get_value (sub_node tree path)
+
+(* return false if the node doesn't exists or if it is not associated to any
value *)
+let rec mem tree = function
+ | [] -> false
+ | h::t ->
+ mem_node tree h
+ && (let node = find_node tree h in
+ if t = []
+ then node.Node.value <> None
+ else mem node.Node.children t)
+
+(* Iterate over the longest valid prefix *)
+let rec iter_path f tree = function
+ | [] -> ()
+ | h::l ->
+ if mem_node tree h
+ then begin
+ let node = find_node tree h in
+ f node.Node.key node.Node.value;
+ iter_path f node.Node.children l
+ end
+
+let rec set_node node path value =
+ if path = []
+ then Node.set_value node value
+ else begin
+ let children = set node.Node.children path value in
+ Node.set_children node children
+ end
+
+and set tree path value =
+ match path with
+ | [] -> raise Not_found
+ | h::t ->
+ if mem_node tree h
+ then begin
+ let node = find_node tree h in
+ replace_node tree h (set_node node t value)
+ end else begin
+ let node = Node.empty h in
+ set_node node t value :: tree
+ end
+
+let rec unset tree = function
+ | [] -> tree
+ | h::t ->
+ if mem_node tree h
+ then begin
+ let node = find_node tree h in
+ let children = unset node.Node.children t in
+ let new_node =
+ if t = []
+ then Node.set_children (Node.empty h) children
+ else Node.set_children node children
+ in
+ if children = [] && new_node.Node.value = None
+ then remove_node tree h
+ else replace_node tree h new_node
+ end else
+ raise Not_found
+
diff -r 30f6827de705 -r b36273f2fbc8 tools/ocaml/xenstored/trie.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/trie.mli Fri May 07 08:46:51 2010 +0100
@@ -0,0 +1,60 @@
+(*
+ * Copyright (C) 2008-2009 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxxxxx>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program 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.
+ *)
+
+(** Basic Implementation of polymorphic tries (ie. prefix trees) *)
+
+type ('a, 'b) t
+(** The type of tries. ['a list] is the type of keys, ['b] the type of values.
+ Internally, a trie is represented as a labeled tree, where node
contains values
+ of type ['a * 'b option]. *)
+
+val create : unit -> ('a,'b) t
+(** Creates an empty trie. *)
+
+val mem : ('a,'b) t -> 'a list -> bool
+(** [mem t k] returns true if a value is associated with the key [k] in the
trie [t].
+ Otherwise, it returns false. *)
+
+val find : ('a, 'b) t -> 'a list -> 'b
+(** [find t k] returns the value associated with the key [k] in the trie [t].
+ Returns [Not_found] if no values are associated with [k] in [t]. *)
+
+val set : ('a, 'b) t -> 'a list -> 'b -> ('a, 'b) t
+(** [set t k v] associates the value [v] with the key [k] in the trie [t]. *)
+
+val unset : ('a, 'b) t -> 'a list -> ('a, 'b) t
+(** [unset k v] removes the association of value [v] with the key [k] in the
trie [t].
+ Moreover, it automatically clean the trie, ie. it removes recursively
+ every nodes of [t] containing no values and having no chil. *)
+
+val iter : ('a -> 'b option -> unit) -> ('a, 'b) t -> unit
+(** [iter f t] applies the function [f] to every node of the trie [t].
+ As nodes of the trie [t] do not necessary contains a value, the second
argument of
+ [f] is an option type. *)
+
+val iter_path : ('a -> 'b option -> unit) -> ('a, 'b) t -> 'a list -> unit
+(** [iter_path f t p] iterates [f] over nodes associated with the path [p] in
the trie [t].
+ If [p] is not a valid path of [t], it iterates on the longest valid
prefix of [p]. *)
+
+val fold : ('a -> 'b option -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+(** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value.
*)
+
+val map : ('b -> 'c option) -> ('a,'b) t -> ('a,'c) t
+(** [map f t] maps [f] over every values stored in [t]. The return value of
[f] is of type 'c option
+ as one may wants to remove value associated to a key. This function is
not tail-recursive. *)
+
+val sub : ('a, 'b) t -> 'a list -> ('a,'b) t
+(** [sub t p] returns the sub-trie associated with the path [p] in the trie
[t].
+ If [p] is not a valid path of [t], it returns an empty trie. *)
_______________________________________________
Xen-changelog mailing list
Xen-changelog@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/xen-changelog
|
Home