ocam: add missing files that got lost in the v2 shuffle

Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>

3 files changed, 372 insertions, 0 deletions

diff --git a/tools/ocaml/xenstored/stdext.ml b/tools/ocaml/xenstored/stdext.ml
new file mode 100644
index 0000000000..b8a8fd00e1
--- /dev/null
+++ b/tools/ocaml/xenstored/stdext.ml
@@ -0,0 +1,130 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008-2010 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * 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 --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
new file mode 100644
index 0000000000..bc9a903582
--- /dev/null
+++ b/tools/ocaml/xenstored/trie.ml
@@ -0,0 +1,182 @@
+(*
+ * Copyright (C) 2008-2009 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * 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 --git a/tools/ocaml/xenstored/trie.mli b/tools/ocaml/xenstored/trie.mli
new file mode 100644
index 0000000000..25db9d05f3
--- /dev/null
+++ b/tools/ocaml/xenstored/trie.mli
@@ -0,0 +1,60 @@
+(*
+ * Copyright (C) 2008-2009 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * 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. *)