1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
(*
* 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 Filename = struct
include Filename
let quote_command cmd args =
cmd :: args |> List.map quote |> String.concat " "
end
module Map = struct
module Make(Ord: Map.OrderedType) = struct
include Map.Make(Ord)
let find_opt k t = try Some (find k t) with Not_found -> None
let update k f t =
let r = find_opt k t in
let r' = f r in
match r, r' with
| None, None -> t
| Some _, None -> remove k t
| Some r, Some r' when r == r' -> t
| _, Some r' -> add k r' t
end
end
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_RDWR ] 0 in
begin try
Unix.dup2 nullfd 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_substring fd buf 0 len <> len
then failwith "pidfile_write failed";
)
(fun () -> Unix.close fd)
end
|
