|
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index] [xen master] tools/ocaml: run 'make format' on OCaml files
commit ea250e81cfc709feccd47a682dbaf805bde08e87
Author: Edwin Török <edwin.torok@xxxxxxxxx>
AuthorDate: Thu Jan 12 17:26:39 2023 +0000
Commit: Andrew Cooper <andrew.cooper3@xxxxxxxxxx>
CommitDate: Mon Feb 6 10:22:12 2023 +0000
tools/ocaml: run 'make format' on OCaml files
`git log -p -1 -w` proves the change here is only whitespace.
No functional change.
Signed-off-by: Edwin Török <edwin.torok@xxxxxxxxx>
Acked-by: Christian Lindig <christian.lindig@xxxxxxxxxx>
---
tools/ocaml/libs/mmap/xenmmap.ml | 2 +-
tools/ocaml/libs/mmap/xenmmap.mli | 4 +-
tools/ocaml/libs/xb/op.ml | 76 +--
tools/ocaml/libs/xb/packet.ml | 30 +-
tools/ocaml/libs/xb/partial.ml | 48 +-
tools/ocaml/libs/xb/xb.ml | 440 ++++++------
tools/ocaml/libs/xb/xb.mli | 106 +--
tools/ocaml/libs/xb/xs_ring.ml | 26 +-
tools/ocaml/libs/xc/xenctrl.ml | 326 ++++-----
tools/ocaml/libs/xc/xenctrl.mli | 12 +-
tools/ocaml/libs/xs/queueop.ml | 48 +-
tools/ocaml/libs/xs/xs.ml | 234 +++----
tools/ocaml/libs/xs/xs.mli | 46 +-
tools/ocaml/libs/xs/xsraw.ml | 300 ++++----
tools/ocaml/libs/xs/xst.ml | 76 +--
tools/ocaml/libs/xs/xst.mli | 20 +-
tools/ocaml/test/dmesg.ml | 26 +-
tools/ocaml/test/list_domains.ml | 4 +-
tools/ocaml/test/raise_exception.ml | 4 +-
tools/ocaml/test/xtl.ml | 28 +-
tools/ocaml/xenstored/config.ml | 156 ++---
tools/ocaml/xenstored/connection.ml | 604 ++++++++---------
tools/ocaml/xenstored/connections.ml | 294 ++++----
tools/ocaml/xenstored/disk.ml | 226 +++---
tools/ocaml/xenstored/domain.ml | 116 ++--
tools/ocaml/xenstored/domains.ml | 310 ++++-----
tools/ocaml/xenstored/event.ml | 28 +-
tools/ocaml/xenstored/history.ml | 62 +-
tools/ocaml/xenstored/logging.ml | 494 +++++++-------
tools/ocaml/xenstored/packet.ml | 20 +-
tools/ocaml/xenstored/parse_arg.ml | 106 +--
tools/ocaml/xenstored/perms.ml | 234 +++----
tools/ocaml/xenstored/poll.ml | 68 +-
tools/ocaml/xenstored/poll.mli | 4 +-
tools/ocaml/xenstored/process.ml | 1244 +++++++++++++++++-----------------
tools/ocaml/xenstored/quota.ml | 74 +-
tools/ocaml/xenstored/stdext.ml | 206 +++---
tools/ocaml/xenstored/store.ml | 822 +++++++++++-----------
tools/ocaml/xenstored/symbol.ml | 2 +-
tools/ocaml/xenstored/syslog.ml | 48 +-
tools/ocaml/xenstored/transaction.ml | 352 +++++-----
tools/ocaml/xenstored/trie.ml | 234 +++----
tools/ocaml/xenstored/trie.mli | 22 +-
tools/ocaml/xenstored/utils.ml | 146 ++--
tools/ocaml/xenstored/xenstored.ml | 1070 ++++++++++++++---------------
45 files changed, 4399 insertions(+), 4399 deletions(-)
diff --git a/tools/ocaml/libs/mmap/xenmmap.ml b/tools/ocaml/libs/mmap/xenmmap.ml
index 44b67c89d2..fd6735649f 100644
--- a/tools/ocaml/libs/mmap/xenmmap.ml
+++ b/tools/ocaml/libs/mmap/xenmmap.ml
@@ -21,7 +21,7 @@ type mmap_map_flag = SHARED | PRIVATE
(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *)
external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
- -> int -> int -> mmap_interface = "stub_mmap_init"
+ -> int -> int -> mmap_interface = "stub_mmap_init"
external unmap: mmap_interface -> unit = "stub_mmap_final"
(* read: interface -> start -> length -> data *)
external read: mmap_interface -> int -> int -> string = "stub_mmap_read"
diff --git a/tools/ocaml/libs/mmap/xenmmap.mli
b/tools/ocaml/libs/mmap/xenmmap.mli
index 8f92ed6310..d097b68a8f 100644
--- a/tools/ocaml/libs/mmap/xenmmap.mli
+++ b/tools/ocaml/libs/mmap/xenmmap.mli
@@ -19,10 +19,10 @@ type mmap_prot_flag = RDONLY | WRONLY | RDWR
type mmap_map_flag = SHARED | PRIVATE
external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int ->
int
- -> mmap_interface = "stub_mmap_init"
+ -> mmap_interface = "stub_mmap_init"
external unmap : mmap_interface -> unit = "stub_mmap_final"
external read : mmap_interface -> int -> int -> string = "stub_mmap_read"
external write : mmap_interface -> string -> int -> int -> unit
- = "stub_mmap_write"
+ = "stub_mmap_write"
external getpagesize : unit -> int = "stub_mmap_getpagesize"
diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml
index 9bcab0f38c..77cf04a752 100644
--- a/tools/ocaml/libs/xb/op.ml
+++ b/tools/ocaml/libs/xb/op.ml
@@ -23,50 +23,50 @@ type operation = Debug | Directory | Read | Getperms |
Invalid
let operation_c_mapping =
- [| Debug; Directory; Read; Getperms;
- Watch; Unwatch; Transaction_start;
- Transaction_end; Introduce; Release;
- Getdomainpath; Write; Mkdir; Rm;
- Setperms; Watchevent; Error; Isintroduced;
- Resume; Set_target; Invalid; Reset_watches |]
+ [| Debug; Directory; Read; Getperms;
+ Watch; Unwatch; Transaction_start;
+ Transaction_end; Introduce; Release;
+ Getdomainpath; Write; Mkdir; Rm;
+ Setperms; Watchevent; Error; Isintroduced;
+ Resume; Set_target; Invalid; Reset_watches |]
let size = Array.length operation_c_mapping
let array_search el a =
- let len = Array.length a in
- let rec search i =
- if i > len then raise Not_found;
- if a.(i) = el then i else search (i + 1) in
- search 0
+ let len = Array.length a in
+ let rec search i =
+ if i > len then raise Not_found;
+ if a.(i) = el then i else search (i + 1) in
+ search 0
let of_cval i =
- if i >= 0 && i < size
- then operation_c_mapping.(i)
- else Invalid
+ if i >= 0 && i < size
+ then operation_c_mapping.(i)
+ else Invalid
let to_cval op =
- array_search op operation_c_mapping
+ array_search op operation_c_mapping
let to_string ty =
- match ty with
- | Debug -> "DEBUG"
- | Directory -> "DIRECTORY"
- | Read -> "READ"
- | Getperms -> "GET_PERMS"
- | Watch -> "WATCH"
- | Unwatch -> "UNWATCH"
- | Transaction_start -> "TRANSACTION_START"
- | Transaction_end -> "TRANSACTION_END"
- | Introduce -> "INTRODUCE"
- | Release -> "RELEASE"
- | Getdomainpath -> "GET_DOMAIN_PATH"
- | Write -> "WRITE"
- | Mkdir -> "MKDIR"
- | Rm -> "RM"
- | Setperms -> "SET_PERMS"
- | Watchevent -> "WATCH_EVENT"
- | Error -> "ERROR"
- | Isintroduced -> "IS_INTRODUCED"
- | Resume -> "RESUME"
- | Set_target -> "SET_TARGET"
- | Reset_watches -> "RESET_WATCHES"
- | Invalid -> "INVALID"
+ match ty with
+ | Debug -> "DEBUG"
+ | Directory -> "DIRECTORY"
+ | Read -> "READ"
+ | Getperms -> "GET_PERMS"
+ | Watch -> "WATCH"
+ | Unwatch -> "UNWATCH"
+ | Transaction_start -> "TRANSACTION_START"
+ | Transaction_end -> "TRANSACTION_END"
+ | Introduce -> "INTRODUCE"
+ | Release -> "RELEASE"
+ | Getdomainpath -> "GET_DOMAIN_PATH"
+ | Write -> "WRITE"
+ | Mkdir -> "MKDIR"
+ | Rm -> "RM"
+ | Setperms -> "SET_PERMS"
+ | Watchevent -> "WATCH_EVENT"
+ | Error -> "ERROR"
+ | Isintroduced -> "IS_INTRODUCED"
+ | Resume -> "RESUME"
+ | Set_target -> "SET_TARGET"
+ | Reset_watches -> "RESET_WATCHES"
+ | Invalid -> "INVALID"
diff --git a/tools/ocaml/libs/xb/packet.ml b/tools/ocaml/libs/xb/packet.ml
index 74c04bb7ae..cd169c066b 100644
--- a/tools/ocaml/libs/xb/packet.ml
+++ b/tools/ocaml/libs/xb/packet.ml
@@ -15,12 +15,12 @@
*)
type t =
-{
- tid: int;
- rid: int;
- ty: Op.operation;
- data: string;
-}
+ {
+ tid: int;
+ rid: int;
+ ty: Op.operation;
+ data: string;
+ }
exception Error of string
exception DataError of string
@@ -30,21 +30,21 @@ external string_of_header: int -> int -> int -> int ->
string = "stub_string_of_
let create tid rid ty data = { tid = tid; rid = rid; ty = ty; data = data; }
let of_partialpkt ppkt =
- create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty
(Buffer.contents ppkt.Partial.buf)
+ create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents
ppkt.Partial.buf)
let to_string pkt =
- let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty)
(String.length pkt.data) in
- header ^ pkt.data
+ let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty)
(String.length pkt.data) in
+ header ^ pkt.data
let unpack pkt =
- pkt.tid, pkt.rid, pkt.ty, pkt.data
+ pkt.tid, pkt.rid, pkt.ty, pkt.data
let get_tid pkt = pkt.tid
let get_ty pkt = pkt.ty
let get_data pkt =
- let l = String.length pkt.data in
- if l > 0 && pkt.data.[l - 1] = '\000' then
- String.sub pkt.data 0 (l - 1)
- else
- pkt.data
+ let l = String.length pkt.data in
+ if l > 0 && pkt.data.[l - 1] = '\000' then
+ String.sub pkt.data 0 (l - 1)
+ else
+ pkt.data
let get_rid pkt = pkt.rid
\ No newline at end of file
diff --git a/tools/ocaml/libs/xb/partial.ml b/tools/ocaml/libs/xb/partial.ml
index 3aa8927eb7..0e6532807d 100644
--- a/tools/ocaml/libs/xb/partial.ml
+++ b/tools/ocaml/libs/xb/partial.ml
@@ -15,39 +15,39 @@
*)
type pkt =
-{
- tid: int;
- rid: int;
- ty: Op.operation;
- len: int;
- buf: Buffer.t;
-}
+ {
+ tid: int;
+ rid: int;
+ ty: Op.operation;
+ len: int;
+ buf: Buffer.t;
+ }
external header_size: unit -> int = "stub_header_size"
external header_of_string_internal: string -> int * int * int * int
- = "stub_header_of_string"
+ = "stub_header_of_string"
let xenstore_payload_max = 4096 (* xen/include/public/io/xs_wire.h *)
let xenstore_rel_path_max = 2048 (* xen/include/public/io/xs_wire.h *)
let of_string s =
- let tid, rid, opint, dlen = header_of_string_internal s in
- (* A packet which is bigger than xenstore_payload_max is illegal.
- This will leave the guest connection is a bad state and will
- be hard to recover from without restarting the connection
- (ie rebooting the guest) *)
- let dlen = max 0 (min xenstore_payload_max dlen) in
- {
- tid = tid;
- rid = rid;
- ty = (Op.of_cval opint);
- len = dlen;
- buf = Buffer.create dlen;
- }
+ let tid, rid, opint, dlen = header_of_string_internal s in
+ (* A packet which is bigger than xenstore_payload_max is illegal.
+ This will leave the guest connection is a bad state and will
+ be hard to recover from without restarting the connection
+ (ie rebooting the guest) *)
+ let dlen = max 0 (min xenstore_payload_max dlen) in
+ {
+ tid = tid;
+ rid = rid;
+ ty = (Op.of_cval opint);
+ len = dlen;
+ buf = Buffer.create dlen;
+ }
let append pkt s sz =
- if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith
"Buffer.add: cannot grow buffer";
- Buffer.add_substring pkt.buf s 0 sz
+ if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith
"Buffer.add: cannot grow buffer";
+ Buffer.add_substring pkt.buf s 0 sz
let to_complete pkt =
- pkt.len - (Buffer.length pkt.buf)
+ pkt.len - (Buffer.length pkt.buf)
diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml
index b292ed7a87..3e3ef2b29d 100644
--- a/tools/ocaml/libs/xb/xb.ml
+++ b/tools/ocaml/libs/xb/xb.ml
@@ -18,94 +18,94 @@ module Op = struct include Op end
module Packet = struct include Packet end
module BoundedQueue : sig
- type ('a, 'b) t
+ type ('a, 'b) t
- (** [create ~capacity ~classify ~limit] creates a queue with maximum
[capacity] elements.
- This is burst capacity, each element is further classified
according to [classify],
- and each class can have its own [limit].
- [capacity] is enforced as an overall limit.
- The [limit] can be dynamic, and can be smaller than the number of
elements already queued of that class,
- in which case those elements are considered to use "burst capacity".
- *)
- val create: capacity:int -> classify:('a -> 'b) -> limit:('b -> int) ->
('a, 'b) t
+ (** [create ~capacity ~classify ~limit] creates a queue with maximum
[capacity] elements.
+ This is burst capacity, each element is further classified
according to [classify],
+ and each class can have its own [limit].
+ [capacity] is enforced as an overall limit.
+ The [limit] can be dynamic, and can be smaller than the number of
elements already queued of that class,
+ in which case those elements are considered to use "burst capacity".
+ *)
+ val create: capacity:int -> classify:('a -> 'b) -> limit:('b -> int) -> ('a,
'b) t
- (** [clear q] discards all elements from [q] *)
- val clear: ('a, 'b) t -> unit
+ (** [clear q] discards all elements from [q] *)
+ val clear: ('a, 'b) t -> unit
- (** [can_push q] when [length q < capacity]. *)
- val can_push: ('a, 'b) t -> 'b -> bool
+ (** [can_push q] when [length q < capacity]. *)
+ val can_push: ('a, 'b) t -> 'b -> bool
- (** [push e q] adds [e] at the end of queue [q] if [can_push q], or
returns [None]. *)
- val push: 'a -> ('a, 'b) t -> unit option
+ (** [push e q] adds [e] at the end of queue [q] if [can_push q], or returns
[None]. *)
+ val push: 'a -> ('a, 'b) t -> unit option
- (** [pop q] removes and returns first element in [q], or raises
[Queue.Empty]. *)
- val pop: ('a, 'b) t -> 'a
+ (** [pop q] removes and returns first element in [q], or raises
[Queue.Empty]. *)
+ val pop: ('a, 'b) t -> 'a
- (** [peek q] returns the first element in [q], or raises [Queue.Empty].
*)
- val peek : ('a, 'b) t -> 'a
+ (** [peek q] returns the first element in [q], or raises [Queue.Empty]. *)
+ val peek : ('a, 'b) t -> 'a
- (** [length q] returns the current number of elements in [q] *)
- val length: ('a, 'b) t -> int
+ (** [length q] returns the current number of elements in [q] *)
+ val length: ('a, 'b) t -> int
- (** [debug string_of_class q] prints queue usage statistics in an
unspecified internal format. *)
- val debug: ('b -> string) -> (_, 'b) t -> string
+ (** [debug string_of_class q] prints queue usage statistics in an
unspecified internal format. *)
+ val debug: ('b -> string) -> (_, 'b) t -> string
end = struct
- type ('a, 'b) t =
- { q: 'a Queue.t
- ; capacity: int
- ; classify: 'a -> 'b
- ; limit: 'b -> int
- ; class_count: ('b, int) Hashtbl.t
- }
-
- let create ~capacity ~classify ~limit =
- { capacity; q = Queue.create (); classify; limit; class_count =
Hashtbl.create 3 }
-
- let get_count t classification = try Hashtbl.find t.class_count
classification with Not_found -> 0
-
- let can_push_internal t classification class_count =
- Queue.length t.q < t.capacity && class_count < t.limit
classification
-
- let ok = Some ()
-
- let push e t =
- let classification = t.classify e in
- let class_count = get_count t classification in
- if can_push_internal t classification class_count then begin
- Queue.push e t.q;
- Hashtbl.replace t.class_count classification
(class_count + 1);
- ok
- end
- else
- None
-
- let can_push t classification =
- can_push_internal t classification @@ get_count t classification
-
- let clear t =
- Queue.clear t.q;
- Hashtbl.reset t.class_count
-
- let pop t =
- let e = Queue.pop t.q in
- let classification = t.classify e in
- let () = match get_count t classification - 1 with
- | 0 -> Hashtbl.remove t.class_count classification (* reduces
memusage *)
- | n -> Hashtbl.replace t.class_count classification n
- in
- e
-
- let peek t = Queue.peek t.q
- let length t = Queue.length t.q
-
- let debug string_of_class t =
- let b = Buffer.create 128 in
- Printf.bprintf b "BoundedQueue capacity: %d, used: {"
t.capacity;
- Hashtbl.iter (fun packet_class count ->
- Printf.bprintf b " %s: %d" (string_of_class
packet_class) count
- ) t.class_count;
- Printf.bprintf b "}";
- Buffer.contents b
+ type ('a, 'b) t =
+ { q: 'a Queue.t
+ ; capacity: int
+ ; classify: 'a -> 'b
+ ; limit: 'b -> int
+ ; class_count: ('b, int) Hashtbl.t
+ }
+
+ let create ~capacity ~classify ~limit =
+ { capacity; q = Queue.create (); classify; limit; class_count =
Hashtbl.create 3 }
+
+ let get_count t classification = try Hashtbl.find t.class_count
classification with Not_found -> 0
+
+ let can_push_internal t classification class_count =
+ Queue.length t.q < t.capacity && class_count < t.limit classification
+
+ let ok = Some ()
+
+ let push e t =
+ let classification = t.classify e in
+ let class_count = get_count t classification in
+ if can_push_internal t classification class_count then begin
+ Queue.push e t.q;
+ Hashtbl.replace t.class_count classification (class_count + 1);
+ ok
+ end
+ else
+ None
+
+ let can_push t classification =
+ can_push_internal t classification @@ get_count t classification
+
+ let clear t =
+ Queue.clear t.q;
+ Hashtbl.reset t.class_count
+
+ let pop t =
+ let e = Queue.pop t.q in
+ let classification = t.classify e in
+ let () = match get_count t classification - 1 with
+ | 0 -> Hashtbl.remove t.class_count classification (* reduces memusage *)
+ | n -> Hashtbl.replace t.class_count classification n
+ in
+ e
+
+ let peek t = Queue.peek t.q
+ let length t = Queue.length t.q
+
+ let debug string_of_class t =
+ let b = Buffer.create 128 in
+ Printf.bprintf b "BoundedQueue capacity: %d, used: {" t.capacity;
+ Hashtbl.iter (fun packet_class count ->
+ Printf.bprintf b " %s: %d" (string_of_class packet_class) count
+ ) t.class_count;
+ Printf.bprintf b "}";
+ Buffer.contents b
end
@@ -119,16 +119,16 @@ let _ =
Callback.register_exception "Xb.Reconnect" Reconnect
type backend_mmap =
-{
- mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *)
- eventchn_notify: unit -> unit; (* function to notify through eventchn *)
- mutable work_again: bool;
-}
+ {
+ mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *)
+ eventchn_notify: unit -> unit; (* function to notify through eventchn *)
+ mutable work_again: bool;
+ }
type backend_fd =
-{
- fd: Unix.file_descr;
-}
+ {
+ fd: Unix.file_descr;
+ }
type backend = Fd of backend_fd | Xenmmap of backend_mmap
@@ -144,104 +144,104 @@ type capacity = { maxoutstanding: int; maxwatchevents:
int }
module Queue = BoundedQueue
type packet_class =
- | CommandReply
- | Watchevent
+ | CommandReply
+ | Watchevent
let string_of_packet_class = function
- | CommandReply -> "command_reply"
- | Watchevent -> "watch_event"
+ | CommandReply -> "command_reply"
+ | Watchevent -> "watch_event"
type t =
-{
- backend: backend;
- pkt_out: (Packet.t, packet_class) Queue.t;
- mutable partial_in: partial_buf;
- mutable partial_out: string;
- capacity: capacity
-}
+ {
+ backend: backend;
+ pkt_out: (Packet.t, packet_class) Queue.t;
+ mutable partial_in: partial_buf;
+ mutable partial_out: string;
+ capacity: capacity
+ }
let to_read con =
- match con.partial_in with
- | HaveHdr partial_pkt -> Partial.to_complete partial_pkt
- | NoHdr (i, _) -> i
+ match con.partial_in with
+ | HaveHdr partial_pkt -> Partial.to_complete partial_pkt
+ | NoHdr (i, _) -> i
let debug t =
- Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d
bytes, pkt_out: %d packets, %s"
- (to_read t)
- (String.length t.partial_out)
- (Queue.length t.pkt_out)
- (BoundedQueue.debug string_of_packet_class t.pkt_out)
+ Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d bytes,
pkt_out: %d packets, %s"
+ (to_read t)
+ (String.length t.partial_out)
+ (Queue.length t.pkt_out)
+ (BoundedQueue.debug string_of_packet_class t.pkt_out)
let init_partial_in () = NoHdr
- (Partial.header_size (), Bytes.make (Partial.header_size()) '\000')
+ (Partial.header_size (), Bytes.make (Partial.header_size()) '\000')
let reconnect t = match t.backend with
- | Fd _ ->
- (* should never happen, so close the connection *)
- raise End_of_file
- | Xenmmap backend ->
- Xs_ring.close backend.mmap;
- backend.eventchn_notify ();
- (* Clear our old connection state *)
- Queue.clear t.pkt_out;
- t.partial_in <- init_partial_in ();
- t.partial_out <- ""
+ | Fd _ ->
+ (* should never happen, so close the connection *)
+ raise End_of_file
+ | Xenmmap backend ->
+ Xs_ring.close backend.mmap;
+ backend.eventchn_notify ();
+ (* Clear our old connection state *)
+ Queue.clear t.pkt_out;
+ t.partial_in <- init_partial_in ();
+ t.partial_out <- ""
let queue con pkt = Queue.push pkt con.pkt_out
let read_fd back _con b len =
- let rd = Unix.read back.fd b 0 len in
- if rd = 0 then
- raise End_of_file;
- rd
+ let rd = Unix.read back.fd b 0 len in
+ if rd = 0 then
+ raise End_of_file;
+ rd
let read_mmap back _con b len =
- let s = Bytes.make len '\000' in
- let rd = Xs_ring.read back.mmap s len in
- Bytes.blit s 0 b 0 rd;
- back.work_again <- (rd > 0);
- if rd > 0 then
- back.eventchn_notify ();
- rd
+ let s = Bytes.make len '\000' in
+ let rd = Xs_ring.read back.mmap s len in
+ Bytes.blit s 0 b 0 rd;
+ back.work_again <- (rd > 0);
+ if rd > 0 then
+ back.eventchn_notify ();
+ rd
let read con b len =
- match con.backend with
- | Fd backfd -> read_fd backfd con b len
- | Xenmmap backmmap -> read_mmap backmmap con b len
+ match con.backend with
+ | Fd backfd -> read_fd backfd con b len
+ | Xenmmap backmmap -> read_mmap backmmap con b len
let write_fd back _con b len =
- Unix.write_substring back.fd b 0 len
+ Unix.write_substring back.fd b 0 len
let write_mmap back _con s len =
- let ws = Xs_ring.write_substring back.mmap s len in
- if ws > 0 then
- back.eventchn_notify ();
- ws
+ let ws = Xs_ring.write_substring back.mmap s len in
+ if ws > 0 then
+ back.eventchn_notify ();
+ ws
let write con s len =
- match con.backend with
- | Fd backfd -> write_fd backfd con s len
- | Xenmmap backmmap -> write_mmap backmmap con s len
+ match con.backend with
+ | Fd backfd -> write_fd backfd con s len
+ | Xenmmap backmmap -> write_mmap backmmap con s len
(* NB: can throw Reconnect *)
let output con =
- (* get the output string from a string_of(packet) or partial_out *)
- let s = if String.length con.partial_out > 0 then
- con.partial_out
- else if Queue.length con.pkt_out > 0 then
- let pkt = Queue.pop con.pkt_out in
- Packet.to_string pkt
- else
- "" in
- (* send data from s, and save the unsent data to partial_out *)
- if s <> "" then (
- let len = String.length s in
- let sz = write con s len in
- let left = String.sub s sz (len - sz) in
- con.partial_out <- left
- );
- (* after sending one packet, partial is empty *)
- con.partial_out = ""
+ (* get the output string from a string_of(packet) or partial_out *)
+ let s = if String.length con.partial_out > 0 then
+ con.partial_out
+ else if Queue.length con.pkt_out > 0 then
+ let pkt = Queue.pop con.pkt_out in
+ Packet.to_string pkt
+ else
+ "" in
+ (* send data from s, and save the unsent data to partial_out *)
+ if s <> "" then (
+ let len = String.length s in
+ let sz = write con s len in
+ let left = String.sub s sz (len - sz) in
+ con.partial_out <- left
+ );
+ (* after sending one packet, partial is empty *)
+ con.partial_out = ""
(* we can only process an input packet if we're guaranteed to have room
to store the response packet *)
@@ -249,71 +249,71 @@ let can_input con = Queue.can_push con.pkt_out
CommandReply
(* NB: can throw Reconnect *)
let input con =
- if not (can_input con) then None
- else
- let to_read = to_read con in
-
- (* try to get more data from input stream *)
- let b = Bytes.make to_read '\000' in
- let sz = if to_read > 0 then read con b to_read else 0 in
-
- (
- match con.partial_in with
- | HaveHdr partial_pkt ->
- (* we complete the data *)
- if sz > 0 then
- Partial.append partial_pkt (Bytes.to_string b) sz;
- if Partial.to_complete partial_pkt = 0 then (
- let pkt = Packet.of_partialpkt partial_pkt in
- con.partial_in <- init_partial_in ();
- Some pkt
- ) else None
- | NoHdr (i, buf) ->
- (* we complete the partial header *)
- if sz > 0 then
- Bytes.blit b 0 buf (Partial.header_size () - i) sz;
- con.partial_in <- if sz = i then
- HaveHdr (Partial.of_string (Bytes.to_string buf)) else
NoHdr (i - sz, buf);
- None
- )
+ if not (can_input con) then None
+ else
+ let to_read = to_read con in
+
+ (* try to get more data from input stream *)
+ let b = Bytes.make to_read '\000' in
+ let sz = if to_read > 0 then read con b to_read else 0 in
+
+ (
+ match con.partial_in with
+ | HaveHdr partial_pkt ->
+ (* we complete the data *)
+ if sz > 0 then
+ Partial.append partial_pkt (Bytes.to_string b) sz;
+ if Partial.to_complete partial_pkt = 0 then (
+ let pkt = Packet.of_partialpkt partial_pkt in
+ con.partial_in <- init_partial_in ();
+ Some pkt
+ ) else None
+ | NoHdr (i, buf) ->
+ (* we complete the partial header *)
+ if sz > 0 then
+ Bytes.blit b 0 buf (Partial.header_size () - i) sz;
+ con.partial_in <- if sz = i then
+ HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i -
sz, buf);
+ None
+ )
let classify t =
- match t.Packet.ty with
- | Op.Watchevent -> Watchevent
- | _ -> CommandReply
+ match t.Packet.ty with
+ | Op.Watchevent -> Watchevent
+ | _ -> CommandReply
let newcon ~capacity backend =
- let limit = function
- | CommandReply -> capacity.maxoutstanding
- | Watchevent -> capacity.maxwatchevents
- in
- {
- backend = backend;
- pkt_out = Queue.create ~capacity:(capacity.maxoutstanding +
capacity.maxwatchevents) ~classify ~limit;
- partial_in = init_partial_in ();
- partial_out = "";
- capacity = capacity;
- }
+ let limit = function
+ | CommandReply -> capacity.maxoutstanding
+ | Watchevent -> capacity.maxwatchevents
+ in
+ {
+ backend = backend;
+ pkt_out = Queue.create ~capacity:(capacity.maxoutstanding +
capacity.maxwatchevents) ~classify ~limit;
+ partial_in = init_partial_in ();
+ partial_out = "";
+ capacity = capacity;
+ }
let open_fd fd = newcon (Fd { fd = fd; })
let open_mmap mmap notifyfct =
- (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *)
- Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton
Xs_ring.Server_feature.Reconnection);
- newcon (Xenmmap {
- mmap = mmap;
- eventchn_notify = notifyfct;
- work_again = false; })
+ (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *)
+ Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton
Xs_ring.Server_feature.Reconnection);
+ newcon (Xenmmap {
+ mmap = mmap;
+ eventchn_notify = notifyfct;
+ work_again = false; })
let close con =
- match con.backend with
- | Fd backend -> Unix.close backend.fd
- | Xenmmap backend -> Xenmmap.unmap backend.mmap
+ match con.backend with
+ | Fd backend -> Unix.close backend.fd
+ | Xenmmap backend -> Xenmmap.unmap backend.mmap
let is_fd con =
- match con.backend with
- | Fd _ -> true
- | Xenmmap _ -> false
+ match con.backend with
+ | Fd _ -> true
+ | Xenmmap _ -> false
let is_mmap con = not (is_fd con)
@@ -326,19 +326,19 @@ let has_output con = has_new_output con || has_old_output
con
let peek_output con = Queue.peek con.pkt_out
let has_partial_input con = match con.partial_in with
- | HaveHdr _ -> true
- | NoHdr (n, _) -> n < Partial.header_size ()
+ | HaveHdr _ -> true
+ | NoHdr (n, _) -> n < Partial.header_size ()
let has_more_input con =
- match con.backend with
- | Fd _ -> false
- | Xenmmap backend -> backend.work_again
+ match con.backend with
+ | Fd _ -> false
+ | Xenmmap backend -> backend.work_again
let is_selectable con =
- match con.backend with
- | Fd _ -> true
- | Xenmmap _ -> false
+ match con.backend with
+ | Fd _ -> true
+ | Xenmmap _ -> false
let get_fd con =
- match con.backend with
- | Fd backend -> backend.fd
- | Xenmmap _ -> raise (Failure "get_fd")
+ match con.backend with
+ | Fd backend -> backend.fd
+ | Xenmmap _ -> raise (Failure "get_fd")
diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli
index 71b2754ca7..e6bb3809dc 100644
--- a/tools/ocaml/libs/xb/xb.mli
+++ b/tools/ocaml/libs/xb/xb.mli
@@ -1,58 +1,58 @@
module Op :
- sig
- type operation =
- Op.operation =
- Debug
- | Directory
- | Read
- | Getperms
- | Watch
- | Unwatch
- | Transaction_start
- | Transaction_end
- | Introduce
- | Release
- | Getdomainpath
- | Write
- | Mkdir
- | Rm
- | Setperms
- | Watchevent
- | Error
- | Isintroduced
- | Resume
- | Set_target
- | Reset_watches
- | Invalid
- val operation_c_mapping : operation array
- val size : int
- val array_search : 'a -> 'a array -> int
- val of_cval : int -> operation
- val to_cval : operation -> int
- val to_string : operation -> string
- end
+sig
+ type operation =
+ Op.operation =
+ Debug
+ | Directory
+ | Read
+ | Getperms
+ | Watch
+ | Unwatch
+ | Transaction_start
+ | Transaction_end
+ | Introduce
+ | Release
+ | Getdomainpath
+ | Write
+ | Mkdir
+ | Rm
+ | Setperms
+ | Watchevent
+ | Error
+ | Isintroduced
+ | Resume
+ | Set_target
+ | Reset_watches
+ | Invalid
+ val operation_c_mapping : operation array
+ val size : int
+ val array_search : 'a -> 'a array -> int
+ val of_cval : int -> operation
+ val to_cval : operation -> int
+ val to_string : operation -> string
+end
module Packet :
- sig
- type t =
- Packet.t = {
- tid : int;
- rid : int;
- ty : Op.operation;
- data : string;
- }
- exception Error of string
- exception DataError of string
- external string_of_header : int -> int -> int -> int -> string
- = "stub_string_of_header"
- val create : int -> int -> Op.operation -> string -> t
- val of_partialpkt : Partial.pkt -> t
- val to_string : t -> string
- val unpack : t -> int * int * Op.operation * string
- val get_tid : t -> int
- val get_ty : t -> Op.operation
- val get_data : t -> string
- val get_rid : t -> int
- end
+sig
+ type t =
+ Packet.t = {
+ tid : int;
+ rid : int;
+ ty : Op.operation;
+ data : string;
+ }
+ exception Error of string
+ exception DataError of string
+ external string_of_header : int -> int -> int -> int -> string
+ = "stub_string_of_header"
+ val create : int -> int -> Op.operation -> string -> t
+ val of_partialpkt : Partial.pkt -> t
+ val to_string : t -> string
+ val unpack : t -> int * int * Op.operation * string
+ val get_tid : t -> int
+ val get_ty : t -> Op.operation
+ val get_data : t -> string
+ val get_rid : t -> int
+end
exception End_of_file
exception Eagain
exception Noent
diff --git a/tools/ocaml/libs/xb/xs_ring.ml b/tools/ocaml/libs/xb/xs_ring.ml
index dd5e014a33..87c6b243e4 100644
--- a/tools/ocaml/libs/xb/xs_ring.ml
+++ b/tools/ocaml/libs/xb/xs_ring.ml
@@ -15,14 +15,14 @@
*)
module Server_feature = struct
- type t =
- | Reconnection
+ type t =
+ | Reconnection
end
module Server_features = Set.Make(struct
- type t = Server_feature.t
- let compare = compare
-end)
+ type t = Server_feature.t
+ let compare = compare
+ end)
external read: Xenmmap.mmap_interface -> bytes -> int -> int =
"ml_interface_read"
external write_substring: Xenmmap.mmap_interface -> string -> int -> int =
"ml_interface_write"
@@ -31,15 +31,15 @@ external _internal_set_server_features:
Xenmmap.mmap_interface -> int -> unit =
external _internal_get_server_features: Xenmmap.mmap_interface -> int =
"ml_interface_get_server_features" [@@noalloc]
let get_server_features mmap =
- (* NB only one feature currently defined above *)
- let x = _internal_get_server_features mmap in
- if x = 0
- then Server_features.empty
- else Server_features.singleton Server_feature.Reconnection
+ (* NB only one feature currently defined above *)
+ let x = _internal_get_server_features mmap in
+ if x = 0
+ then Server_features.empty
+ else Server_features.singleton Server_feature.Reconnection
let set_server_features mmap set =
- (* NB only one feature currently defined above *)
- let x = if set = Server_features.empty then 0 else 1 in
- _internal_set_server_features mmap x
+ (* NB only one feature currently defined above *)
+ let x = if set = Server_features.empty then 0 else 1 in
+ _internal_set_server_features mmap x
external close: Xenmmap.mmap_interface -> unit = "ml_interface_close"
[@@noalloc]
diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml
index 7442bbbfc5..a59dee0938 100644
--- a/tools/ocaml/libs/xc/xenctrl.ml
+++ b/tools/ocaml/libs/xc/xenctrl.ml
@@ -20,153 +20,153 @@ type domid = int
(* ** xenctrl.h ** *)
type vcpuinfo =
-{
- online: bool;
- blocked: bool;
- running: bool;
- cputime: int64;
- cpumap: int32;
-}
+ {
+ online: bool;
+ blocked: bool;
+ running: bool;
+ cputime: int64;
+ cpumap: int32;
+ }
type xen_arm_arch_domainconfig =
-{
- gic_version: int;
- nr_spis: int;
- clock_frequency: int32;
-}
+ {
+ gic_version: int;
+ nr_spis: int;
+ clock_frequency: int32;
+ }
type x86_arch_emulation_flags =
- | X86_EMU_LAPIC
- | X86_EMU_HPET
- | X86_EMU_PM
- | X86_EMU_RTC
- | X86_EMU_IOAPIC
- | X86_EMU_PIC
- | X86_EMU_VGA
- | X86_EMU_IOMMU
- | X86_EMU_PIT
- | X86_EMU_USE_PIRQ
- | X86_EMU_VPCI
+ | X86_EMU_LAPIC
+ | X86_EMU_HPET
+ | X86_EMU_PM
+ | X86_EMU_RTC
+ | X86_EMU_IOAPIC
+ | X86_EMU_PIC
+ | X86_EMU_VGA
+ | X86_EMU_IOMMU
+ | X86_EMU_PIT
+ | X86_EMU_USE_PIRQ
+ | X86_EMU_VPCI
type x86_arch_misc_flags =
- | X86_MSR_RELAXED
+ | X86_MSR_RELAXED
type xen_x86_arch_domainconfig =
-{
- emulation_flags: x86_arch_emulation_flags list;
- misc_flags: x86_arch_misc_flags list;
-}
+ {
+ emulation_flags: x86_arch_emulation_flags list;
+ misc_flags: x86_arch_misc_flags list;
+ }
type arch_domainconfig =
- | ARM of xen_arm_arch_domainconfig
- | X86 of xen_x86_arch_domainconfig
+ | ARM of xen_arm_arch_domainconfig
+ | X86 of xen_x86_arch_domainconfig
type domain_create_flag =
- | CDF_HVM
- | CDF_HAP
- | CDF_S3_INTEGRITY
- | CDF_OOS_OFF
- | CDF_XS_DOMAIN
- | CDF_IOMMU
- | CDF_NESTED_VIRT
- | CDF_VPMU
+ | CDF_HVM
+ | CDF_HAP
+ | CDF_S3_INTEGRITY
+ | CDF_OOS_OFF
+ | CDF_XS_DOMAIN
+ | CDF_IOMMU
+ | CDF_NESTED_VIRT
+ | CDF_VPMU
type domain_create_iommu_opts =
- | IOMMU_NO_SHAREPT
+ | IOMMU_NO_SHAREPT
type domctl_create_config =
-{
- ssidref: int32;
- handle: string;
- flags: domain_create_flag list;
- iommu_opts: domain_create_iommu_opts list;
- max_vcpus: int;
- max_evtchn_port: int;
- max_grant_frames: int;
- max_maptrack_frames: int;
- max_grant_version: int;
- cpupool_id: int32;
- arch: arch_domainconfig;
-}
+ {
+ ssidref: int32;
+ handle: string;
+ flags: domain_create_flag list;
+ iommu_opts: domain_create_iommu_opts list;
+ max_vcpus: int;
+ max_evtchn_port: int;
+ max_grant_frames: int;
+ max_maptrack_frames: int;
+ max_grant_version: int;
+ cpupool_id: int32;
+ arch: arch_domainconfig;
+ }
type domaininfo =
-{
- domid : domid;
- dying : bool;
- shutdown : bool;
- paused : bool;
- blocked : bool;
- running : bool;
- hvm_guest : bool;
- shutdown_code : int;
- total_memory_pages: nativeint;
- max_memory_pages : nativeint;
- shared_info_frame : int64;
- cpu_time : int64;
- nr_online_vcpus : int;
- max_vcpu_id : int;
- ssidref : int32;
- handle : int array;
- arch_config : arch_domainconfig;
-}
+ {
+ domid : domid;
+ dying : bool;
+ shutdown : bool;
+ paused : bool;
+ blocked : bool;
+ running : bool;
+ hvm_guest : bool;
+ shutdown_code : int;
+ total_memory_pages: nativeint;
+ max_memory_pages : nativeint;
+ shared_info_frame : int64;
+ cpu_time : int64;
+ nr_online_vcpus : int;
+ max_vcpu_id : int;
+ ssidref : int32;
+ handle : int array;
+ arch_config : arch_domainconfig;
+ }
type sched_control =
-{
- weight : int;
- cap : int;
-}
+ {
+ weight : int;
+ cap : int;
+ }
type physinfo_cap_flag =
- | CAP_HVM
- | CAP_PV
- | CAP_DirectIO
- | CAP_HAP
- | CAP_Shadow
- | CAP_IOMMU_HAP_PT_SHARE
- | CAP_Vmtrace
- | CAP_Vpmu
- | CAP_Gnttab_v1
- | CAP_Gnttab_v2
+ | CAP_HVM
+ | CAP_PV
+ | CAP_DirectIO
+ | CAP_HAP
+ | CAP_Shadow
+ | CAP_IOMMU_HAP_PT_SHARE
+ | CAP_Vmtrace
+ | CAP_Vpmu
+ | CAP_Gnttab_v1
+ | CAP_Gnttab_v2
type arm_physinfo_cap_flag
type x86_physinfo_cap_flag
type arch_physinfo_cap_flags =
- | ARM of arm_physinfo_cap_flag list
- | X86 of x86_physinfo_cap_flag list
+ | ARM of arm_physinfo_cap_flag list
+ | X86 of x86_physinfo_cap_flag list
type physinfo =
-{
- threads_per_core : int;
- cores_per_socket : int;
- nr_cpus : int;
- max_node_id : int;
- cpu_khz : int;
- total_pages : nativeint;
- free_pages : nativeint;
- scrub_pages : nativeint;
- (* XXX hw_cap *)
- capabilities : physinfo_cap_flag list;
- max_nr_cpus : int;
- arch_capabilities : arch_physinfo_cap_flags;
-}
+ {
+ threads_per_core : int;
+ cores_per_socket : int;
+ nr_cpus : int;
+ max_node_id : int;
+ cpu_khz : int;
+ total_pages : nativeint;
+ free_pages : nativeint;
+ scrub_pages : nativeint;
+ (* XXX hw_cap *)
+ capabilities : physinfo_cap_flag list;
+ max_nr_cpus : int;
+ arch_capabilities : arch_physinfo_cap_flags;
+ }
type version =
-{
- major : int;
- minor : int;
- extra : string;
-}
+ {
+ major : int;
+ minor : int;
+ extra : string;
+ }
type compile_info =
-{
- compiler : string;
- compile_by : string;
- compile_domain : string;
- compile_date : string;
-}
+ {
+ compiler : string;
+ compile_by : string;
+ compile_domain : string;
+ compile_date : string;
+ }
type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Watchdog |
Soft_reset
@@ -181,34 +181,34 @@ let handle = ref None
let get_handle () = !handle
let close_handle () =
- match !handle with
- | Some _ -> handle := None
- | None -> ()
+ match !handle with
+ | Some _ -> handle := None
+ | None -> ()
let with_intf f =
- match !handle with
- | Some h -> f h
- | None ->
- let h =
- try interface_open () with
- | e ->
- let msg = Printexc.to_string e in
- failwith ("failed to open xenctrl: "^msg)
- in
- handle := Some h;
- f h
+ match !handle with
+ | Some h -> f h
+ | None ->
+ let h =
+ try interface_open () with
+ | e ->
+ let msg = Printexc.to_string e in
+ failwith ("failed to open xenctrl: "^msg)
+ in
+ handle := Some h;
+ f h
external domain_create_stub: handle -> domid -> domctl_create_config -> domid
- = "stub_xc_domain_create"
+ = "stub_xc_domain_create"
let domain_create handle ?(domid=0) config =
- domain_create_stub handle domid config
+ domain_create_stub handle domid config
external domain_sethandle: handle -> domid -> string -> unit
- = "stub_xc_domain_sethandle"
+ = "stub_xc_domain_sethandle"
external domain_max_vcpus: handle -> domid -> int -> unit
- = "stub_xc_domain_max_vcpus"
+ = "stub_xc_domain_max_vcpus"
external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause"
external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause"
@@ -216,10 +216,10 @@ external domain_resume_fast: handle -> domid -> unit =
"stub_xc_domain_resume_fa
external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy"
external domain_shutdown: handle -> domid -> shutdown_reason -> unit
- = "stub_xc_domain_shutdown"
+ = "stub_xc_domain_shutdown"
external _domain_getinfolist: handle -> domid -> int -> domaininfo list
- = "stub_xc_domain_getinfolist"
+ = "stub_xc_domain_getinfolist"
let rev_append_fold acc e = List.rev_append e acc
@@ -228,53 +228,53 @@ let rev_append_fold acc e = List.rev_append e acc
* except it is tail recursive, whereas [List.concat] isn't.
* Example:
* rev_concat [[10;9;8];[7;6];[5]]] = [5; 6; 7; 8; 9; 10]
- *)
+*)
let rev_concat lst = List.fold_left rev_append_fold [] lst
let domain_getinfolist handle first_domain =
- let nb = 1024 in
- let rec __getlist lst from =
- (* _domain_getinfolist returns domains in reverse order,
largest first *)
- match _domain_getinfolist handle from nb with
- | [] -> rev_concat lst
- | (hd :: _) as l -> __getlist (l :: lst) (hd.domid + 1)
- in
- __getlist [] first_domain
+ let nb = 1024 in
+ let rec __getlist lst from =
+ (* _domain_getinfolist returns domains in reverse order, largest first *)
+ match _domain_getinfolist handle from nb with
+ | [] -> rev_concat lst
+ | (hd :: _) as l -> __getlist (l :: lst) (hd.domid + 1)
+ in
+ __getlist [] first_domain
external domain_getinfo: handle -> domid -> domaininfo=
"stub_xc_domain_getinfo"
external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo
- = "stub_xc_vcpu_getinfo"
+ = "stub_xc_vcpu_getinfo"
external domain_ioport_permission: handle -> domid -> int -> int -> bool ->
unit
- = "stub_xc_domain_ioport_permission"
+ = "stub_xc_domain_ioport_permission"
external domain_iomem_permission: handle -> domid -> nativeint -> nativeint ->
bool -> unit
- = "stub_xc_domain_iomem_permission"
+ = "stub_xc_domain_iomem_permission"
external domain_irq_permission: handle -> domid -> int -> bool -> unit
- = "stub_xc_domain_irq_permission"
+ = "stub_xc_domain_irq_permission"
external vcpu_affinity_set: handle -> domid -> int -> bool array -> unit
- = "stub_xc_vcpu_setaffinity"
+ = "stub_xc_vcpu_setaffinity"
external vcpu_affinity_get: handle -> domid -> int -> bool array
- = "stub_xc_vcpu_getaffinity"
+ = "stub_xc_vcpu_getaffinity"
external vcpu_context_get: handle -> domid -> int -> string
- = "stub_xc_vcpu_context_get"
+ = "stub_xc_vcpu_context_get"
external sched_id: handle -> int = "stub_xc_sched_id"
external sched_credit_domain_set: handle -> domid -> sched_control -> unit
- = "stub_sched_credit_domain_set"
+ = "stub_sched_credit_domain_set"
external sched_credit_domain_get: handle -> domid -> sched_control
- = "stub_sched_credit_domain_get"
+ = "stub_sched_credit_domain_get"
external shadow_allocation_set: handle -> domid -> int -> unit
- = "stub_shadow_allocation_set"
+ = "stub_shadow_allocation_set"
external shadow_allocation_get: handle -> domid -> int
- = "stub_shadow_allocation_get"
+ = "stub_shadow_allocation_get"
external evtchn_alloc_unbound: handle -> domid -> domid -> int
- = "stub_xc_evtchn_alloc_unbound"
+ = "stub_xc_evtchn_alloc_unbound"
external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset"
(* FIFO has theoretical maximum of 2^28 ports, fits in an int *)
@@ -299,15 +299,15 @@ external physinfo: handle -> physinfo = "stub_xc_physinfo"
external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info"
external domain_setmaxmem: handle -> domid -> int64 -> unit
- = "stub_xc_domain_setmaxmem"
+ = "stub_xc_domain_setmaxmem"
external domain_set_memmap_limit: handle -> domid -> int64 -> unit
- = "stub_xc_domain_set_memmap_limit"
+ = "stub_xc_domain_set_memmap_limit"
external domain_memory_increase_reservation: handle -> domid -> int64 -> unit
- = "stub_xc_domain_memory_increase_reservation"
+ = "stub_xc_domain_memory_increase_reservation"
external map_foreign_range: handle -> domid -> int
- -> nativeint -> Xenmmap.mmap_interface
- = "stub_map_foreign_range"
+ -> nativeint -> Xenmmap.mmap_interface
+ = "stub_map_foreign_range"
type hvm_param =
| HVM_PARAM_CALLBACK_IRQ
@@ -357,15 +357,15 @@ external hvm_param_set: handle -> domid -> hvm_param ->
int64 -> unit
= "stub_xc_hvm_param_set"
external domain_assign_device: handle -> domid -> (int * int * int * int) ->
unit
- = "stub_xc_domain_assign_device"
+ = "stub_xc_domain_assign_device"
external domain_deassign_device: handle -> domid -> (int * int * int * int) ->
unit
- = "stub_xc_domain_deassign_device"
+ = "stub_xc_domain_deassign_device"
external domain_test_assign_device: handle -> domid -> (int * int * int * int)
-> bool
- = "stub_xc_domain_test_assign_device"
+ = "stub_xc_domain_test_assign_device"
external version: handle -> version = "stub_xc_version_version"
external version_compile_info: handle -> compile_info
- = "stub_xc_version_compile_info"
+ = "stub_xc_version_compile_info"
external version_changeset: handle -> string = "stub_xc_version_changeset"
external version_capabilities: handle -> string =
"stub_xc_version_capabilities"
@@ -380,7 +380,7 @@ external watchdog : handle -> int -> int32 -> int
(**
Convert the given number of pages to an amount in KiB, rounded up.
- *)
+*)
external pages_to_kib : int64 -> int64 = "stub_pages_to_kib"
let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L
diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli
index 82def5a17c..3154e90f4f 100644
--- a/tools/ocaml/libs/xc/xenctrl.mli
+++ b/tools/ocaml/libs/xc/xenctrl.mli
@@ -182,11 +182,11 @@ external domain_getinfo : handle -> domid -> domaininfo
external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo
= "stub_xc_vcpu_getinfo"
external domain_ioport_permission: handle -> domid -> int -> int -> bool ->
unit
- = "stub_xc_domain_ioport_permission"
+ = "stub_xc_domain_ioport_permission"
external domain_iomem_permission: handle -> domid -> nativeint -> nativeint ->
bool -> unit
- = "stub_xc_domain_iomem_permission"
+ = "stub_xc_domain_iomem_permission"
external domain_irq_permission: handle -> domid -> int -> bool -> unit
- = "stub_xc_domain_irq_permission"
+ = "stub_xc_domain_irq_permission"
external vcpu_affinity_set : handle -> domid -> int -> bool array -> unit
= "stub_xc_vcpu_setaffinity"
external vcpu_affinity_get : handle -> domid -> int -> bool array
@@ -284,11 +284,11 @@ external hvm_param_set: handle -> domid -> hvm_param ->
int64 -> unit
= "stub_xc_hvm_param_set"
external domain_assign_device: handle -> domid -> (int * int * int * int) ->
unit
- = "stub_xc_domain_assign_device"
+ = "stub_xc_domain_assign_device"
external domain_deassign_device: handle -> domid -> (int * int * int * int) ->
unit
- = "stub_xc_domain_deassign_device"
+ = "stub_xc_domain_deassign_device"
external domain_test_assign_device: handle -> domid -> (int * int * int * int)
-> bool
- = "stub_xc_domain_test_assign_device"
+ = "stub_xc_domain_test_assign_device"
external version : handle -> version = "stub_xc_version_version"
external version_compile_info : handle -> compile_info
diff --git a/tools/ocaml/libs/xs/queueop.ml b/tools/ocaml/libs/xs/queueop.ml
index 4e532cdaea..e069ab7a9c 100644
--- a/tools/ocaml/libs/xs/queueop.ml
+++ b/tools/ocaml/libs/xs/queueop.ml
@@ -18,8 +18,8 @@ open Xenbus
let data_concat ls = (String.concat "\000" ls) ^ "\000"
let queue con pkt = let r = Xb.queue con pkt in assert (r <> None)
let queue_path ty (tid: int) (path: string) con =
- let data = data_concat [ path; ] in
- queue con (Xb.Packet.create tid 0 ty data)
+ let data = data_concat [ path; ] in
+ queue con (Xb.Packet.create tid 0 ty data)
(* operations *)
let directory tid path con = queue_path Xb.Op.Directory tid path con
@@ -28,48 +28,48 @@ let read tid path con = queue_path Xb.Op.Read tid path con
let getperms tid path con = queue_path Xb.Op.Getperms tid path con
let debug commands con =
- queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands))
+ queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands))
let watch path data con =
- let data = data_concat [ path; data; ] in
- queue con (Xb.Packet.create 0 0 Xb.Op.Watch data)
+ let data = data_concat [ path; data; ] in
+ queue con (Xb.Packet.create 0 0 Xb.Op.Watch data)
let unwatch path data con =
- let data = data_concat [ path; data; ] in
- queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data)
+ let data = data_concat [ path; data; ] in
+ queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data)
let transaction_start con =
- queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat
[]))
+ queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat []))
let transaction_end tid commit con =
- let data = data_concat [ (if commit then "T" else "F"); ] in
- queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data)
+ let data = data_concat [ (if commit then "T" else "F"); ] in
+ queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data)
let introduce domid mfn port con =
- let data = data_concat [ Printf.sprintf "%u" domid;
- Printf.sprintf "%nu" mfn;
- string_of_int port; ] in
- queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data)
+ let data = data_concat [ Printf.sprintf "%u" domid;
+ Printf.sprintf "%nu" mfn;
+ string_of_int port; ] in
+ queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data)
let release domid con =
- let data = data_concat [ Printf.sprintf "%u" domid; ] in
- queue con (Xb.Packet.create 0 0 Xb.Op.Release data)
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ queue con (Xb.Packet.create 0 0 Xb.Op.Release data)
let resume domid con =
- let data = data_concat [ Printf.sprintf "%u" domid; ] in
- queue con (Xb.Packet.create 0 0 Xb.Op.Resume data)
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ queue con (Xb.Packet.create 0 0 Xb.Op.Resume data)
let getdomainpath domid con =
- let data = data_concat [ Printf.sprintf "%u" domid; ] in
- queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data)
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data)
let write tid path value con =
- let data = path ^ "\000" ^ value (* no NULL at the end *) in
- queue con (Xb.Packet.create tid 0 Xb.Op.Write data)
+ let data = path ^ "\000" ^ value (* no NULL at the end *) in
+ queue con (Xb.Packet.create tid 0 Xb.Op.Write data)
let mkdir tid path con = queue_path Xb.Op.Mkdir tid path con
let rm tid path con = queue_path Xb.Op.Rm tid path con
let setperms tid path perms con =
- let data = data_concat [ path; perms ] in
- queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data)
+ let data = data_concat [ path; perms ] in
+ queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data)
diff --git a/tools/ocaml/libs/xs/xs.ml b/tools/ocaml/libs/xs/xs.ml
index 90bd68d73d..addccc8009 100644
--- a/tools/ocaml/libs/xs/xs.ml
+++ b/tools/ocaml/libs/xs/xs.ml
@@ -19,46 +19,46 @@ type con = Xsraw.con
type domid = int
type xsh =
-{
- con: con;
- debug: string list -> string;
- directory: string -> string list;
- read: string -> string;
- readv: string -> string list -> string list;
- write: string -> string -> unit;
- writev: string -> (string * string) list -> unit;
- mkdir: string -> unit;
- rm: string -> unit;
- getperms: string -> perms;
- setperms: string -> perms -> unit;
- setpermsv: string -> string list -> perms -> unit;
- introduce: domid -> nativeint -> int -> unit;
- release: domid -> unit;
- resume: domid -> unit;
- getdomainpath: domid -> string;
- watch: string -> string -> unit;
- unwatch: string -> string -> unit;
-}
+ {
+ con: con;
+ debug: string list -> string;
+ directory: string -> string list;
+ read: string -> string;
+ readv: string -> string list -> string list;
+ write: string -> string -> unit;
+ writev: string -> (string * string) list -> unit;
+ mkdir: string -> unit;
+ rm: string -> unit;
+ getperms: string -> perms;
+ setperms: string -> perms -> unit;
+ setpermsv: string -> string list -> perms -> unit;
+ introduce: domid -> nativeint -> int -> unit;
+ release: domid -> unit;
+ resume: domid -> unit;
+ getdomainpath: domid -> string;
+ watch: string -> string -> unit;
+ unwatch: string -> string -> unit;
+ }
let get_operations con = {
- con = con;
- debug = (fun commands -> Xsraw.debug commands con);
- directory = (fun path -> Xsraw.directory 0 path con);
- read = (fun path -> Xsraw.read 0 path con);
- readv = (fun dir vec -> Xsraw.readv 0 dir vec con);
- write = (fun path value -> Xsraw.write 0 path value con);
- writev = (fun dir vec -> Xsraw.writev 0 dir vec con);
- mkdir = (fun path -> Xsraw.mkdir 0 path con);
- rm = (fun path -> Xsraw.rm 0 path con);
- getperms = (fun path -> Xsraw.getperms 0 path con);
- setperms = (fun path perms -> Xsraw.setperms 0 path perms con);
- setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con);
- introduce = (fun id mfn port -> Xsraw.introduce id mfn port con);
- release = (fun id -> Xsraw.release id con);
- resume = (fun id -> Xsraw.resume id con);
- getdomainpath = (fun id -> Xsraw.getdomainpath id con);
- watch = (fun path data -> Xsraw.watch path data con);
- unwatch = (fun path data -> Xsraw.unwatch path data con);
+ con = con;
+ debug = (fun commands -> Xsraw.debug commands con);
+ directory = (fun path -> Xsraw.directory 0 path con);
+ read = (fun path -> Xsraw.read 0 path con);
+ readv = (fun dir vec -> Xsraw.readv 0 dir vec con);
+ write = (fun path value -> Xsraw.write 0 path value con);
+ writev = (fun dir vec -> Xsraw.writev 0 dir vec con);
+ mkdir = (fun path -> Xsraw.mkdir 0 path con);
+ rm = (fun path -> Xsraw.rm 0 path con);
+ getperms = (fun path -> Xsraw.getperms 0 path con);
+ setperms = (fun path perms -> Xsraw.setperms 0 path perms con);
+ setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con);
+ introduce = (fun id mfn port -> Xsraw.introduce id mfn port con);
+ release = (fun id -> Xsraw.release id con);
+ resume = (fun id -> Xsraw.resume id con);
+ getdomainpath = (fun id -> Xsraw.getdomainpath id con);
+ watch = (fun path data -> Xsraw.watch path data con);
+ unwatch = (fun path data -> Xsraw.unwatch path data con);
}
let transaction xsh = Xst.transaction xsh.con
@@ -81,71 +81,71 @@ exception Timeout_with_nonempty_queue
let max_blocking_time = 5. (* seconds *)
let read_watchevent_timeout xsh timeout callback =
- let start_time = Unix.gettimeofday () in
- let end_time = start_time +. timeout in
-
- let left = ref timeout in
-
- (* Returns true if a watch event in the queue satisfied us *)
- let process_queued_events () =
- let success = ref false in
- while Xsraw.has_watchevents xsh.con && not(!success)
- do
- success := callback (Xsraw.get_watchevent xsh.con)
- done;
- !success in
- (* Returns true if a watch event read from the socket satisfied us *)
- let process_incoming_event () =
- let fd = get_fd xsh in
- let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time
!left) in
-
- (* If data is available for reading then read it *)
- if r = []
- then false (* timeout, either a max_blocking_time or global *)
- else callback (Xsraw.read_watchevent xsh.con) in
-
- let success = ref false in
- while !left > 0. && not(!success)
- do
- (* NB the 'callback' might call back into Xs functions
- and as a side-effect, watches might be queued. Hence
- we must process the queue on every loop iteration *)
-
- (* First process all queued watch events *)
- if not(!success)
- then success := process_queued_events ();
- (* Then block for one more watch event *)
- if not(!success)
- then success := process_incoming_event ();
- (* Just in case our callback caused events to be queued
- and this is our last time round the loop: this prevents
- us throwing the Timeout_with_nonempty_queue spuriously *)
- if not(!success)
- then success := process_queued_events ();
-
- (* Update the time left *)
- let current_time = Unix.gettimeofday () in
- left := end_time -. current_time
- done;
- if not(!success) then begin
- (* Sanity check: it should be impossible for any
- events to be queued here *)
- if Xsraw.has_watchevents xsh.con
- then raise Timeout_with_nonempty_queue
- else raise Timeout
- end
+ let start_time = Unix.gettimeofday () in
+ let end_time = start_time +. timeout in
+
+ let left = ref timeout in
+
+ (* Returns true if a watch event in the queue satisfied us *)
+ let process_queued_events () =
+ let success = ref false in
+ while Xsraw.has_watchevents xsh.con && not(!success)
+ do
+ success := callback (Xsraw.get_watchevent xsh.con)
+ done;
+ !success in
+ (* Returns true if a watch event read from the socket satisfied us *)
+ let process_incoming_event () =
+ let fd = get_fd xsh in
+ let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in
+
+ (* If data is available for reading then read it *)
+ if r = []
+ then false (* timeout, either a max_blocking_time or global *)
+ else callback (Xsraw.read_watchevent xsh.con) in
+
+ let success = ref false in
+ while !left > 0. && not(!success)
+ do
+ (* NB the 'callback' might call back into Xs functions
+ and as a side-effect, watches might be queued. Hence
+ we must process the queue on every loop iteration *)
+
+ (* First process all queued watch events *)
+ if not(!success)
+ then success := process_queued_events ();
+ (* Then block for one more watch event *)
+ if not(!success)
+ then success := process_incoming_event ();
+ (* Just in case our callback caused events to be queued
+ and this is our last time round the loop: this
prevents
+ us throwing the Timeout_with_nonempty_queue
spuriously *)
+ if not(!success)
+ then success := process_queued_events ();
+
+ (* Update the time left *)
+ let current_time = Unix.gettimeofday () in
+ left := end_time -. current_time
+ done;
+ if not(!success) then begin
+ (* Sanity check: it should be impossible for any
+ events to be queued here *)
+ if Xsraw.has_watchevents xsh.con
+ then raise Timeout_with_nonempty_queue
+ else raise Timeout
+ end
let monitor_paths xsh l time callback =
- let unwatch () =
- List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in
- List.iter (fun (w,v) -> xsh.watch w v) l;
- begin try
- read_watchevent_timeout xsh time callback;
- with
- exn -> unwatch (); raise exn;
- end;
- unwatch ()
+ let unwatch () =
+ List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in
+ List.iter (fun (w,v) -> xsh.watch w v) l;
+ begin try
+ read_watchevent_timeout xsh time callback;
+ with
+ exn -> unwatch (); raise exn;
+ end;
+ unwatch ()
let daemon_socket = Paths.xen_run_stored ^ "/socket"
@@ -153,24 +153,24 @@ let daemon_socket = Paths.xen_run_stored ^ "/socket"
exception Failed_to_connect
let daemon_open () =
- try
- let sockaddr = Unix.ADDR_UNIX(daemon_socket) in
- let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
- Unix.connect sock sockaddr;
- Unix.set_close_on_exec sock;
- make sock
- with _ -> raise Failed_to_connect
+ try
+ let sockaddr = Unix.ADDR_UNIX(daemon_socket) in
+ let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+ Unix.connect sock sockaddr;
+ Unix.set_close_on_exec sock;
+ make sock
+ with _ -> raise Failed_to_connect
let domain_open () =
- let path = try
- let devpath = "/dev/xen/xenbus" in
- Unix.access devpath [ Unix.F_OK ];
- devpath
- with Unix.Unix_error(_, _, _) ->
- "/proc/xen/xenbus" in
-
- let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in
- Unix.set_close_on_exec fd;
- make fd
+ let path = try
+ let devpath = "/dev/xen/xenbus" in
+ Unix.access devpath [ Unix.F_OK ];
+ devpath
+ with Unix.Unix_error(_, _, _) ->
+ "/proc/xen/xenbus" in
+
+ let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in
+ Unix.set_close_on_exec fd;
+ make fd
let close xsh = Xsraw.close xsh.con
diff --git a/tools/ocaml/libs/xs/xs.mli b/tools/ocaml/libs/xs/xs.mli
index ce505b659b..cf8855c7d8 100644
--- a/tools/ocaml/libs/xs/xs.mli
+++ b/tools/ocaml/libs/xs/xs.mli
@@ -23,31 +23,31 @@ exception Failed_to_connect
- owner domid.
- other perm: applied to domain that is not owner or in ACL.
- ACL: list of per-domain permission
- *)
+*)
type perms = Xsraw.perms
type domid = int
type con
type xsh = {
- con : con;
- debug: string list -> string;
- directory : string -> string list;
- read : string -> string;
- readv : string -> string list -> string list;
- write : string -> string -> unit;
- writev : string -> (string * string) list -> unit;
- mkdir : string -> unit;
- rm : string -> unit;
- getperms : string -> perms;
- setperms : string -> perms -> unit;
- setpermsv : string -> string list -> perms -> unit;
- introduce : domid -> nativeint -> int -> unit;
- release : domid -> unit;
- resume : domid -> unit;
- getdomainpath : domid -> string;
- watch : string -> string -> unit;
- unwatch : string -> string -> unit;
+ con : con;
+ debug: string list -> string;
+ directory : string -> string list;
+ read : string -> string;
+ readv : string -> string list -> string list;
+ write : string -> string -> unit;
+ writev : string -> (string * string) list -> unit;
+ mkdir : string -> unit;
+ rm : string -> unit;
+ getperms : string -> perms;
+ setperms : string -> perms -> unit;
+ setpermsv : string -> string list -> perms -> unit;
+ introduce : domid -> nativeint -> int -> unit;
+ release : domid -> unit;
+ resume : domid -> unit;
+ getdomainpath : domid -> string;
+ watch : string -> string -> unit;
+ unwatch : string -> string -> unit;
}
(** get operations provide a vector of xenstore function that apply to one
@@ -75,10 +75,10 @@ val read_watchevent_timeout : xsh -> float -> (string *
string -> bool) -> unit
(** register a set of watches, then wait for watchevent.
remove all watches previously set before giving back the hand. *)
val monitor_paths : xsh
- -> (string * string) list
- -> float
- -> (string * string -> bool)
- -> unit
+ -> (string * string) list
+ -> float
+ -> (string * string -> bool)
+ -> unit
(** open a socket-based xenstored connection *)
val daemon_open : unit -> xsh
diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml
index cbd1728060..d51e40eed3 100644
--- a/tools/ocaml/libs/xs/xsraw.ml
+++ b/tools/ocaml/libs/xs/xsraw.ml
@@ -23,239 +23,239 @@ exception Unexpected_packet of string
exception Invalid_path of string
let unexpected_packet expected received =
- let s = Printf.sprintf "expecting %s received %s"
- (Xb.Op.to_string expected)
- (Xb.Op.to_string received) in
- raise (Unexpected_packet s)
+ let s = Printf.sprintf "expecting %s received %s"
+ (Xb.Op.to_string expected)
+ (Xb.Op.to_string received) in
+ raise (Unexpected_packet s)
type con = {
- xb: Xenbus.Xb.t;
- watchevents: (string * string) Queue.t;
+ xb: Xenbus.Xb.t;
+ watchevents: (string * string) Queue.t;
}
let close con =
- Xb.close con.xb
+ Xb.close con.xb
let capacity = { Xb.maxoutstanding = 1; maxwatchevents = 0; }
let open_fd fd = {
- xb = Xb.open_fd ~capacity fd;
- watchevents = Queue.create ();
+ xb = Xb.open_fd ~capacity fd;
+ watchevents = Queue.create ();
}
let rec split_string ?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_string ~limit: nlimit c b)
+ 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_string ~limit: nlimit c b)
type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR
type perms = int * perm * (int * perm) list
let string_of_perms perms =
- let owner, other, acl = perms in
- let char_of_perm perm =
- match perm with PERM_NONE -> 'n' | PERM_READ -> 'r'
- | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in
- let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm
perm) id in
- String.concat "\000" (List.map string_of_perm ((owner,other) :: acl))
+ let owner, other, acl = perms in
+ let char_of_perm perm =
+ match perm with PERM_NONE -> 'n' | PERM_READ -> 'r'
+ | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in
+ let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id
in
+ String.concat "\000" (List.map string_of_perm ((owner,other) :: acl))
let perms_of_string s =
- let perm_of_char c =
- match c with 'n' -> PERM_NONE | 'r' -> PERM_READ
- | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR
- | c -> invalid_arg (Printf.sprintf "unknown
permission type: %c" c) in
- let perm_of_string s =
- if String.length s < 2
- then invalid_arg (Printf.sprintf "perm of string: length = %d;
contents=\"%s\"" (String.length s) s)
- else
- begin
- int_of_string (String.sub s 1 (String.length s - 1)),
- perm_of_char s.[0]
- end in
- let rec split s =
- try let i = String.index s '\000' in
- String.sub s 0 i :: split (String.sub s (i + 1) (String.length
s - 1 - i))
- with Not_found -> if s = "" then [] else [ s ] in
- let l = List.map perm_of_string (split s) in
- match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, [])
+ let perm_of_char c =
+ match c with 'n' -> PERM_NONE | 'r' -> PERM_READ
+ | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR
+ | c -> invalid_arg (Printf.sprintf "unknown
permission type: %c" c) in
+ let perm_of_string s =
+ if String.length s < 2
+ then invalid_arg (Printf.sprintf "perm of string: length = %d;
contents=\"%s\"" (String.length s) s)
+ else
+ begin
+ int_of_string (String.sub s 1 (String.length s - 1)),
+ perm_of_char s.[0]
+ end in
+ let rec split s =
+ try let i = String.index s '\000' in
+ String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 -
i))
+ with Not_found -> if s = "" then [] else [ s ] in
+ let l = List.map perm_of_string (split s) in
+ match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, [])
(* send one packet - can sleep *)
let pkt_send con =
- if Xb.has_old_output con.xb then
- raise Partial_not_empty;
- let workdone = ref false in
- while not !workdone
- do
- workdone := Xb.output con.xb
- done
+ if Xb.has_old_output con.xb then
+ raise Partial_not_empty;
+ let workdone = ref false in
+ while not !workdone
+ do
+ workdone := Xb.output con.xb
+ done
(* receive one packet - can sleep *)
let rec pkt_recv con =
- match Xb.input con.xb with
- | Some packet -> packet
- | None -> pkt_recv con
+ match Xb.input con.xb with
+ | Some packet -> packet
+ | None -> pkt_recv con
let pkt_recv_timeout con timeout =
- let fd = Xb.get_fd con.xb in
- let r, _, _ = Unix.select [ fd ] [] [] timeout in
- if r = [] then
- true, None
- else
- false, Xb.input con.xb
+ let fd = Xb.get_fd con.xb in
+ let r, _, _ = Unix.select [ fd ] [] [] timeout in
+ if r = [] then
+ true, None
+ else
+ false, Xb.input con.xb
let queue_watchevent con data =
- let ls = split_string ~limit:2 '\000' data in
- if List.length ls != 2 then
- raise (Xb.Packet.DataError "arguments number mismatch");
- let event = List.nth ls 0
- and event_data = List.nth ls 1 in
- Queue.push (event, event_data) con.watchevents
+ let ls = split_string ~limit:2 '\000' data in
+ if List.length ls != 2 then
+ raise (Xb.Packet.DataError "arguments number mismatch");
+ let event = List.nth ls 0
+ and event_data = List.nth ls 1 in
+ Queue.push (event, event_data) con.watchevents
let has_watchevents con = Queue.length con.watchevents > 0
let get_watchevent con = Queue.pop con.watchevents
let read_watchevent con =
- let pkt = pkt_recv con in
- match Xb.Packet.get_ty pkt with
- | Xb.Op.Watchevent ->
- queue_watchevent con (Xb.Packet.get_data pkt);
- Queue.pop con.watchevents
- | ty -> unexpected_packet Xb.Op.Watchevent ty
+ let pkt = pkt_recv con in
+ match Xb.Packet.get_ty pkt with
+ | Xb.Op.Watchevent ->
+ queue_watchevent con (Xb.Packet.get_data pkt);
+ Queue.pop con.watchevents
+ | ty -> unexpected_packet Xb.Op.Watchevent ty
(* send one packet in the queue, and wait for reply *)
let rec sync_recv ty con =
- let pkt = pkt_recv con in
- match Xb.Packet.get_ty pkt with
- | Xb.Op.Error -> (
- match Xb.Packet.get_data pkt with
- | "ENOENT" -> raise Xb.Noent
- | "EAGAIN" -> raise Xb.Eagain
- | "EINVAL" -> raise Xb.Invalid
- | s -> raise (Xb.Packet.Error s))
- | Xb.Op.Watchevent ->
- queue_watchevent con (Xb.Packet.get_data pkt);
- sync_recv ty con
- | rty when rty = ty -> Xb.Packet.get_data pkt
- | rty -> unexpected_packet ty rty
+ let pkt = pkt_recv con in
+ match Xb.Packet.get_ty pkt with
+ | Xb.Op.Error -> (
+ match Xb.Packet.get_data pkt with
+ | "ENOENT" -> raise Xb.Noent
+ | "EAGAIN" -> raise Xb.Eagain
+ | "EINVAL" -> raise Xb.Invalid
+ | s -> raise (Xb.Packet.Error s))
+ | Xb.Op.Watchevent ->
+ queue_watchevent con (Xb.Packet.get_data pkt);
+ sync_recv ty con
+ | rty when rty = ty -> Xb.Packet.get_data pkt
+ | rty -> unexpected_packet ty rty
let sync f con =
- (* queue a query using function f *)
- f con.xb;
- if Xb.output_len con.xb = 0 then
- Printf.printf "output len = 0\n%!";
- let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in
- pkt_send con;
- sync_recv ty con
+ (* queue a query using function f *)
+ f con.xb;
+ if Xb.output_len con.xb = 0 then
+ Printf.printf "output len = 0\n%!";
+ let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in
+ pkt_send con;
+ sync_recv ty con
let ack s =
- if s = "OK" then () else raise (Xb.Packet.DataError s)
+ if s = "OK" then () else raise (Xb.Packet.DataError s)
(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT
watches) *)
let validate_path path =
- (* Paths shouldn't have a "//" in the middle *)
- let bad = "//" in
- for offset = 0 to String.length path - (String.length bad) do
- if String.sub path offset (String.length bad) = bad then
- raise (Invalid_path path)
- done;
- (* Paths shouldn't have a "/" at the end, except for the root *)
- if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then
- raise (Invalid_path path)
+ (* Paths shouldn't have a "//" in the middle *)
+ let bad = "//" in
+ for offset = 0 to String.length path - (String.length bad) do
+ if String.sub path offset (String.length bad) = bad then
+ raise (Invalid_path path)
+ done;
+ (* Paths shouldn't have a "/" at the end, except for the root *)
+ if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then
+ raise (Invalid_path path)
(** Check to see if a path is suitable for watches *)
let validate_watch_path path =
- (* Check for stuff like @releaseDomain etc first *)
- if path <> "" && path.[0] = '@' then ()
- else validate_path path
+ (* Check for stuff like @releaseDomain etc first *)
+ if path <> "" && path.[0] = '@' then ()
+ else validate_path path
let debug command con =
- sync (Queueop.debug command) con
+ sync (Queueop.debug command) con
let directory tid path con =
- validate_path path;
- let data = sync (Queueop.directory tid path) con in
- split_string '\000' data
+ validate_path path;
+ let data = sync (Queueop.directory tid path) con in
+ split_string '\000' data
let read tid path con =
- validate_path path;
- sync (Queueop.read tid path) con
+ validate_path path;
+ sync (Queueop.read tid path) con
let readv tid dir vec con =
- List.map (fun path -> validate_path path; read tid path con)
- (if dir <> "" then
- (List.map (fun v -> dir ^ "/" ^ v) vec) else vec)
+ List.map (fun path -> validate_path path; read tid path con)
+ (if dir <> "" then
+ (List.map (fun v -> dir ^ "/" ^ v) vec) else vec)
let getperms tid path con =
- validate_path path;
- perms_of_string (sync (Queueop.getperms tid path) con)
+ validate_path path;
+ perms_of_string (sync (Queueop.getperms tid path) con)
let watch path data con =
- validate_watch_path path;
- ack (sync (Queueop.watch path data) con)
+ validate_watch_path path;
+ ack (sync (Queueop.watch path data) con)
let unwatch path data con =
- validate_watch_path path;
- ack (sync (Queueop.unwatch path data) con)
+ validate_watch_path path;
+ ack (sync (Queueop.unwatch path data) con)
let transaction_start con =
- let data = sync (Queueop.transaction_start) con in
- try
- int_of_string data
- with
- _ -> raise (Packet.DataError (Printf.sprintf "int expected; got
'%s'" data))
+ let data = sync (Queueop.transaction_start) con in
+ try
+ int_of_string data
+ with
+ _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'"
data))
let transaction_end tid commit con =
- try
- ack (sync (Queueop.transaction_end tid commit) con);
- true
- with
- Xb.Eagain -> false
+ try
+ ack (sync (Queueop.transaction_end tid commit) con);
+ true
+ with
+ Xb.Eagain -> false
let introduce domid mfn port con =
- ack (sync (Queueop.introduce domid mfn port) con)
+ ack (sync (Queueop.introduce domid mfn port) con)
let release domid con =
- ack (sync (Queueop.release domid) con)
+ ack (sync (Queueop.release domid) con)
let resume domid con =
- ack (sync (Queueop.resume domid) con)
+ ack (sync (Queueop.resume domid) con)
let getdomainpath domid con =
- sync (Queueop.getdomainpath domid) con
+ sync (Queueop.getdomainpath domid) con
let write tid path value con =
- validate_path path;
- ack (sync (Queueop.write tid path value) con)
+ validate_path path;
+ ack (sync (Queueop.write tid path value) con)
let writev tid dir vec con =
- List.iter (fun (entry, value) ->
- let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
- validate_path path;
- write tid path value con) vec
+ List.iter (fun (entry, value) ->
+ let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
+ validate_path path;
+ write tid path value con) vec
let mkdir tid path con =
- validate_path path;
- ack (sync (Queueop.mkdir tid path) con)
+ validate_path path;
+ ack (sync (Queueop.mkdir tid path) con)
let rm tid path con =
- validate_path path;
- try
- ack (sync (Queueop.rm tid path) con)
- with
- Xb.Noent -> ()
+ validate_path path;
+ try
+ ack (sync (Queueop.rm tid path) con)
+ with
+ Xb.Noent -> ()
let setperms tid path perms con =
- validate_path path;
- ack (sync (Queueop.setperms tid path (string_of_perms perms)) con)
+ validate_path path;
+ ack (sync (Queueop.setperms tid path (string_of_perms perms)) con)
let setpermsv tid dir vec perms con =
- List.iter (fun entry ->
- let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
- validate_path path;
- setperms tid path perms con) vec
+ List.iter (fun entry ->
+ let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
+ validate_path path;
+ setperms tid path perms con) vec
diff --git a/tools/ocaml/libs/xs/xst.ml b/tools/ocaml/libs/xs/xst.ml
index 16affd2e07..50a980b915 100644
--- a/tools/ocaml/libs/xs/xst.ml
+++ b/tools/ocaml/libs/xs/xst.ml
@@ -15,47 +15,47 @@
*)
type ops =
-{
- directory: string -> string list;
- read: string -> string;
- readv: string -> string list -> string list;
- write: string -> string -> unit;
- writev: string -> (string * string) list -> unit;
- mkdir: string -> unit;
- rm: string -> unit;
- getperms: string -> Xsraw.perms;
- setperms: string -> Xsraw.perms -> unit;
- setpermsv: string -> string list -> Xsraw.perms -> unit;
-}
+ {
+ directory: string -> string list;
+ read: string -> string;
+ readv: string -> string list -> string list;
+ write: string -> string -> unit;
+ writev: string -> (string * string) list -> unit;
+ mkdir: string -> unit;
+ rm: string -> unit;
+ getperms: string -> Xsraw.perms;
+ setperms: string -> Xsraw.perms -> unit;
+ setpermsv: string -> string list -> Xsraw.perms -> unit;
+ }
let get_operations tid xsh = {
- directory = (fun path -> Xsraw.directory tid path xsh);
- read = (fun path -> Xsraw.read tid path xsh);
- readv = (fun dir vec -> Xsraw.readv tid dir vec xsh);
- write = (fun path value -> Xsraw.write tid path value xsh);
- writev = (fun dir vec -> Xsraw.writev tid dir vec xsh);
- mkdir = (fun path -> Xsraw.mkdir tid path xsh);
- rm = (fun path -> Xsraw.rm tid path xsh);
- getperms = (fun path -> Xsraw.getperms tid path xsh);
- setperms = (fun path perms -> Xsraw.setperms tid path perms xsh);
- setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms
xsh);
+ directory = (fun path -> Xsraw.directory tid path xsh);
+ read = (fun path -> Xsraw.read tid path xsh);
+ readv = (fun dir vec -> Xsraw.readv tid dir vec xsh);
+ write = (fun path value -> Xsraw.write tid path value xsh);
+ writev = (fun dir vec -> Xsraw.writev tid dir vec xsh);
+ mkdir = (fun path -> Xsraw.mkdir tid path xsh);
+ rm = (fun path -> Xsraw.rm tid path xsh);
+ getperms = (fun path -> Xsraw.getperms tid path xsh);
+ setperms = (fun path perms -> Xsraw.setperms tid path perms xsh);
+ setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh);
}
let transaction xsh (f: ops -> 'a) : 'a =
- let commited = ref false and result = ref None in
- while not !commited
- do
- let tid = Xsraw.transaction_start xsh in
- let t = get_operations tid xsh in
+ let commited = ref false and result = ref None in
+ while not !commited
+ do
+ let tid = Xsraw.transaction_start xsh in
+ let t = get_operations tid xsh in
- begin try
- result := Some (f t)
- with exn ->
- ignore (Xsraw.transaction_end tid false xsh);
- raise exn
- end;
- commited := Xsraw.transaction_end tid true xsh
- done;
- match !result with
- | None -> failwith "internal error in transaction"
- | Some result -> result
+ begin try
+ result := Some (f t)
+ with exn ->
+ ignore (Xsraw.transaction_end tid false xsh);
+ raise exn
+ end;
+ commited := Xsraw.transaction_end tid true xsh
+ done;
+ match !result with
+ | None -> failwith "internal error in transaction"
+ | Some result -> result
diff --git a/tools/ocaml/libs/xs/xst.mli b/tools/ocaml/libs/xs/xst.mli
index 5ae560424c..08d737bc36 100644
--- a/tools/ocaml/libs/xs/xst.mli
+++ b/tools/ocaml/libs/xs/xst.mli
@@ -14,16 +14,16 @@
* GNU Lesser General Public License for more details.
*)
type ops = {
- directory : string -> string list;
- read : string -> string;
- readv : string -> string list -> string list;
- write : string -> string -> unit;
- writev : string -> (string * string) list -> unit;
- mkdir : string -> unit;
- rm : string -> unit;
- getperms : string -> Xsraw.perms;
- setperms : string -> Xsraw.perms -> unit;
- setpermsv : string -> string list -> Xsraw.perms -> unit;
+ directory : string -> string list;
+ read : string -> string;
+ readv : string -> string list -> string list;
+ write : string -> string -> unit;
+ writev : string -> (string * string) list -> unit;
+ mkdir : string -> unit;
+ rm : string -> unit;
+ getperms : string -> Xsraw.perms;
+ setperms : string -> Xsraw.perms -> unit;
+ setpermsv : string -> string list -> Xsraw.perms -> unit;
}
val get_operations : int -> Xsraw.con -> ops
diff --git a/tools/ocaml/test/dmesg.ml b/tools/ocaml/test/dmesg.ml
index c868024c52..f9efe5dc30 100644
--- a/tools/ocaml/test/dmesg.ml
+++ b/tools/ocaml/test/dmesg.ml
@@ -1,17 +1,17 @@
let _ =
- Xenlight.register_exceptions ();
- let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in
- let ctx = Xenlight.ctx_alloc logger in
+ Xenlight.register_exceptions ();
+ let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in
+ let ctx = Xenlight.ctx_alloc logger in
- let open Xenlight.Host in
- let reader = xen_console_read_start ctx 0 in
- (try
- while true do
- let line = xen_console_read_line ctx reader in
- print_string line
- done
- with End_of_file -> ());
- let _ = xen_console_read_finish ctx reader in
- ()
+ let open Xenlight.Host in
+ let reader = xen_console_read_start ctx 0 in
+ (try
+ while true do
+ let line = xen_console_read_line ctx reader in
+ print_string line
+ done
+ with End_of_file -> ());
+ let _ = xen_console_read_finish ctx reader in
+ ()
diff --git a/tools/ocaml/test/list_domains.ml b/tools/ocaml/test/list_domains.ml
index c8974957fd..94f1cec050 100644
--- a/tools/ocaml/test/list_domains.ml
+++ b/tools/ocaml/test/list_domains.ml
@@ -20,7 +20,7 @@ let _ =
let domains = Xenlight.Dominfo.list ctx in
List.iter (fun d -> print_dominfo d) domains
with Xenlight.Error(err, fn) -> begin
- printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
- end
+ printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
+ end
diff --git a/tools/ocaml/test/raise_exception.ml
b/tools/ocaml/test/raise_exception.ml
index 5ef7fc0f13..8c24c3555b 100644
--- a/tools/ocaml/test/raise_exception.ml
+++ b/tools/ocaml/test/raise_exception.ml
@@ -4,6 +4,6 @@ let _ =
try
Xenlight.test_raise_exception ()
with Xenlight.Error(err, fn) -> begin
- printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
- end
+ printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
+ end
diff --git a/tools/ocaml/test/xtl.ml b/tools/ocaml/test/xtl.ml
index 5f94a76a82..458b11bbaa 100644
--- a/tools/ocaml/test/xtl.ml
+++ b/tools/ocaml/test/xtl.ml
@@ -2,24 +2,24 @@ open Printf
open Xentoollog
let stdio_vmessage min_level level errno ctx msg =
- let level_str = level_to_string level
- and errno_str = match errno with None -> "" | Some s -> sprintf ":
errno=%d" s
- and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in
- if compare min_level level <= 0 then begin
- printf "%s%s%s: %s\n" level_str ctx_str errno_str msg;
- flush stdout;
- end
+ let level_str = level_to_string level
+ and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d"
s
+ and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in
+ if compare min_level level <= 0 then begin
+ printf "%s%s%s: %s\n" level_str ctx_str errno_str msg;
+ flush stdout;
+ end
let stdio_progress _ctx what percent dne total =
- let nl = if dne = total then "\n" else "" in
- printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl;
- flush stdout
+ let nl = if dne = total then "\n" else "" in
+ printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl;
+ flush stdout
let create_stdio_logger ?(level=Info) () =
- let cbs = {
- vmessage = stdio_vmessage level;
- progress = stdio_progress; } in
- create "Xentoollog.stdio_logger" cbs
+ let cbs = {
+ vmessage = stdio_vmessage level;
+ progress = stdio_progress; } in
+ create "Xentoollog.stdio_logger" cbs
let do_test level =
let lgr = create_stdio_logger ~level:level () in
diff --git a/tools/ocaml/xenstored/config.ml b/tools/ocaml/xenstored/config.ml
index 0ee7bc32ff..95ef745a54 100644
--- a/tools/ocaml/xenstored/config.ml
+++ b/tools/ocaml/xenstored/config.ml
@@ -15,98 +15,98 @@
*)
type ty =
- | Set_bool of bool ref
- | Set_int of int ref
- | Set_string of string ref
- | Set_float of float ref
- | Unit of (unit -> unit)
- | Bool of (bool -> unit)
- | Int of (int -> unit)
- | String of (string -> unit)
- | Float of (float -> unit)
+ | Set_bool of bool ref
+ | Set_int of int ref
+ | Set_string of string ref
+ | Set_float of float ref
+ | Unit of (unit -> unit)
+ | Bool of (bool -> unit)
+ | Int of (int -> unit)
+ | String of (string -> unit)
+ | Float of (float -> unit)
exception Error of (string * string) list
let trim_start lc s =
- let len = String.length s and i = ref 0 in
- while !i < len && (List.mem s.[!i] lc)
- do
- incr i
- done;
- if !i < len then String.sub s !i (len - !i) else ""
+ let len = String.length s and i = ref 0 in
+ while !i < len && (List.mem s.[!i] lc)
+ do
+ incr i
+ done;
+ if !i < len then String.sub s !i (len - !i) else ""
let trim_end lc s =
- let i = ref (String.length s - 1) in
- while !i > 0 && (List.mem s.[!i] lc)
- do
- decr i
- done;
- if !i >= 0 then String.sub s 0 (!i + 1) else ""
+ let i = ref (String.length s - 1) in
+ while !i > 0 && (List.mem s.[!i] lc)
+ do
+ decr i
+ done;
+ if !i >= 0 then String.sub s 0 (!i + 1) else ""
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 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 parse_line stream =
- let lc = [ ' '; '\t' ] in
- let trim_spaces s = trim_end lc (trim_start lc s) in
- let to_config s =
- match split ~limit:2 '=' s with
- | k :: v :: [] -> Some (trim_end lc k, trim_start lc v)
- | _ -> None in
- let rec read_filter_line () =
- try
- let line = trim_spaces (input_line stream) in
- if String.length line > 0 && line.[0] <> '#' then
- match to_config line with
- | None -> read_filter_line ()
- | Some x -> x :: read_filter_line ()
- else
- read_filter_line ()
- with
- End_of_file -> [] in
- read_filter_line ()
+ let lc = [ ' '; '\t' ] in
+ let trim_spaces s = trim_end lc (trim_start lc s) in
+ let to_config s =
+ match split ~limit:2 '=' s with
+ | k :: v :: [] -> Some (trim_end lc k, trim_start lc v)
+ | _ -> None in
+ let rec read_filter_line () =
+ try
+ let line = trim_spaces (input_line stream) in
+ if String.length line > 0 && line.[0] <> '#' then
+ match to_config line with
+ | None -> read_filter_line ()
+ | Some x -> x :: read_filter_line ()
+ else
+ read_filter_line ()
+ with
+ End_of_file -> [] in
+ read_filter_line ()
let parse filename =
- let stream = open_in filename in
- let cf = parse_line stream in
- close_in stream;
- cf
+ let stream = open_in filename in
+ let cf = parse_line stream in
+ close_in stream;
+ cf
let validate cf expected other =
- let err = ref [] in
- let append x = err := x :: !err in
- List.iter (fun (k, v) ->
- try
- if not (List.mem_assoc k expected) then
- other k v
- else let ty = List.assoc k expected in
- match ty with
- | Unit f -> f ()
- | Bool f -> f (bool_of_string v)
- | String f -> f v
- | Int f -> f (int_of_string v)
- | Float f -> f (float_of_string v)
- | Set_bool r -> r := (bool_of_string v)
- | Set_string r -> r := v
- | Set_int r -> r := int_of_string v
- | Set_float r -> r := (float_of_string v)
- with
- | Not_found -> append (k, "unknown key")
- | Failure "int_of_string" -> append (k, "expect int arg")
- | Failure "bool_of_string" -> append (k, "expect bool arg")
- | Failure "float_of_string" -> append (k, "expect float arg")
- | exn -> append (k, Printexc.to_string
exn)
- ) cf;
- if !err != [] then raise (Error !err)
+ let err = ref [] in
+ let append x = err := x :: !err in
+ List.iter (fun (k, v) ->
+ try
+ if not (List.mem_assoc k expected) then
+ other k v
+ else let ty = List.assoc k expected in
+ match ty with
+ | Unit f -> f ()
+ | Bool f -> f (bool_of_string v)
+ | String f -> f v
+ | Int f -> f (int_of_string v)
+ | Float f -> f (float_of_string v)
+ | Set_bool r -> r := (bool_of_string v)
+ | Set_string r -> r := v
+ | Set_int r -> r := int_of_string v
+ | Set_float r -> r := (float_of_string v)
+ with
+ | Not_found -> append (k, "unknown key")
+ | Failure "int_of_string" -> append (k, "expect int arg")
+ | Failure "bool_of_string" -> append (k, "expect bool arg")
+ | Failure "float_of_string" -> append (k, "expect float arg")
+ | exn -> append (k, Printexc.to_string exn)
+ ) cf;
+ if !err != [] then raise (Error !err)
(** read a filename, parse and validate, and return the errors if any *)
let read filename expected other =
- let cf = parse filename in
- validate cf expected other
+ let cf = parse filename in
+ validate cf expected other
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index 54f7f76516..d11011e164 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -24,281 +24,281 @@ type 'a bounded_sender = 'a -> unit option
(** a bounded sender accepts an ['a] item and returns:
None - if there is no room to accept the item
Some () - if it has successfully accepted/sent the item
- *)
+*)
module BoundedPipe : sig
- type 'a t
-
- (** [create ~capacity ~destination] creates a bounded pipe with a
- local buffer holding at most [capacity] items. Once the buffer is
- full it will not accept further items. items from the pipe are
- flushed into [destination] as long as it accepts items. The
- destination could be another pipe.
- *)
- val create: capacity:int -> destination:'a bounded_sender -> 'a t
-
- (** [is_empty t] returns whether the local buffer of [t] is empty. *)
- val is_empty : _ t -> bool
-
- (** [length t] the number of items in the internal buffer *)
- val length: _ t -> int
-
- (** [flush_pipe t] sends as many items from the local buffer as
possible,
- which could be none. *)
- val flush_pipe: _ t -> unit
-
- (** [push t item] tries to [flush_pipe] and then push [item]
- into the pipe if its [capacity] allows.
- Returns [None] if there is no more room
- *)
- val push : 'a t -> 'a bounded_sender
+ type 'a t
+
+ (** [create ~capacity ~destination] creates a bounded pipe with a
+ local buffer holding at most [capacity] items. Once the buffer is
+ full it will not accept further items. items from the pipe are
+ flushed into [destination] as long as it accepts items. The
+ destination could be another pipe.
+ *)
+ val create: capacity:int -> destination:'a bounded_sender -> 'a t
+
+ (** [is_empty t] returns whether the local buffer of [t] is empty. *)
+ val is_empty : _ t -> bool
+
+ (** [length t] the number of items in the internal buffer *)
+ val length: _ t -> int
+
+ (** [flush_pipe t] sends as many items from the local buffer as possible,
+ which could be none. *)
+ val flush_pipe: _ t -> unit
+
+ (** [push t item] tries to [flush_pipe] and then push [item]
+ into the pipe if its [capacity] allows.
+ Returns [None] if there is no more room
+ *)
+ val push : 'a t -> 'a bounded_sender
end = struct
- (* items are enqueued in [q], and then flushed to [connect_to] *)
- type 'a t =
- { q: 'a Queue.t
- ; destination: 'a bounded_sender
- ; capacity: int
- }
-
- let create ~capacity ~destination =
- { q = Queue.create (); capacity; destination }
-
- let rec flush_pipe t =
- if not Queue.(is_empty t.q) then
- let item = Queue.peek t.q in
- match t.destination item with
- | None -> () (* no room *)
- | Some () ->
- (* successfully sent item to next stage *)
- let _ = Queue.pop t.q in
- (* continue trying to send more items *)
- flush_pipe t
-
- let push t item =
- (* first try to flush as many items from this pipe as possible
to make room,
- it is important to do this first to preserve the order of
the items
- *)
- flush_pipe t;
- if Queue.length t.q < t.capacity then begin
- (* enqueue, instead of sending directly.
- this ensures that [out] sees the items in the same
order as we receive them
- *)
- Queue.push item t.q;
- Some (flush_pipe t)
- end else None
-
- let is_empty t = Queue.is_empty t.q
- let length t = Queue.length t.q
+ (* items are enqueued in [q], and then flushed to [connect_to] *)
+ type 'a t =
+ { q: 'a Queue.t
+ ; destination: 'a bounded_sender
+ ; capacity: int
+ }
+
+ let create ~capacity ~destination =
+ { q = Queue.create (); capacity; destination }
+
+ let rec flush_pipe t =
+ if not Queue.(is_empty t.q) then
+ let item = Queue.peek t.q in
+ match t.destination item with
+ | None -> () (* no room *)
+ | Some () ->
+ (* successfully sent item to next stage *)
+ let _ = Queue.pop t.q in
+ (* continue trying to send more items *)
+ flush_pipe t
+
+ let push t item =
+ (* first try to flush as many items from this pipe as possible to make
room,
+ it is important to do this first to preserve the
order of the items
+ *)
+ flush_pipe t;
+ if Queue.length t.q < t.capacity then begin
+ (* enqueue, instead of sending directly.
+ this ensures that [out] sees the items in
the same order as we receive them
+ *)
+ Queue.push item t.q;
+ Some (flush_pipe t)
+ end else None
+
+ let is_empty t = Queue.is_empty t.q
+ let length t = Queue.length t.q
end
type watch = {
- con: t;
- token: string;
- path: string;
- base: string;
- is_relative: bool;
- pending_watchevents: Xenbus.Xb.Packet.t BoundedPipe.t;
+ con: t;
+ token: string;
+ path: string;
+ base: string;
+ is_relative: bool;
+ pending_watchevents: Xenbus.Xb.Packet.t BoundedPipe.t;
}
and t = {
- xb: Xenbus.Xb.t;
- dom: Domain.t option;
- transactions: (int, Transaction.t) Hashtbl.t;
- mutable next_tid: int;
- watches: (string, watch list) Hashtbl.t;
- mutable nb_watches: int;
- anonid: int;
- mutable stat_nb_ops: int;
- mutable perm: Perms.Connection.t;
- pending_source_watchevents: (watch * Xenbus.Xb.Packet.t) BoundedPipe.t
+ xb: Xenbus.Xb.t;
+ dom: Domain.t option;
+ transactions: (int, Transaction.t) Hashtbl.t;
+ mutable next_tid: int;
+ watches: (string, watch list) Hashtbl.t;
+ mutable nb_watches: int;
+ anonid: int;
+ mutable stat_nb_ops: int;
+ mutable perm: Perms.Connection.t;
+ pending_source_watchevents: (watch * Xenbus.Xb.Packet.t) BoundedPipe.t
}
module Watch = struct
- module T = struct
- type t = watch
-
- let compare w1 w2 =
- (* cannot compare watches from different connections *)
- assert (w1.con == w2.con);
- match String.compare w1.token w2.token with
- | 0 -> String.compare w1.path w2.path
- | n -> n
- end
- module Set = Set.Make(T)
-
- let flush_events t =
- BoundedPipe.flush_pipe t.pending_watchevents;
- not (BoundedPipe.is_empty t.pending_watchevents)
-
- let pending_watchevents t =
- BoundedPipe.length t.pending_watchevents
+ module T = struct
+ type t = watch
+
+ let compare w1 w2 =
+ (* cannot compare watches from different connections *)
+ assert (w1.con == w2.con);
+ match String.compare w1.token w2.token with
+ | 0 -> String.compare w1.path w2.path
+ | n -> n
+ end
+ module Set = Set.Make(T)
+
+ let flush_events t =
+ BoundedPipe.flush_pipe t.pending_watchevents;
+ not (BoundedPipe.is_empty t.pending_watchevents)
+
+ let pending_watchevents t =
+ BoundedPipe.length t.pending_watchevents
end
let source_flush_watchevents t =
- BoundedPipe.flush_pipe t.pending_source_watchevents
+ BoundedPipe.flush_pipe t.pending_source_watchevents
let source_pending_watchevents t =
- BoundedPipe.length t.pending_source_watchevents
+ BoundedPipe.length t.pending_source_watchevents
let mark_as_bad con =
- match con.dom with
- |None -> ()
- | Some domain -> Domain.mark_as_bad domain
+ match con.dom with
+ |None -> ()
+ | Some domain -> Domain.mark_as_bad domain
let initial_next_tid = 1
let do_reconnect con =
- Xenbus.Xb.reconnect con.xb;
- (* dom is the same *)
- Hashtbl.clear con.transactions;
- con.next_tid <- initial_next_tid;
- Hashtbl.clear con.watches;
- (* anonid is the same *)
- con.nb_watches <- 0;
- con.stat_nb_ops <- 0;
- (* perm is the same *)
- ()
+ Xenbus.Xb.reconnect con.xb;
+ (* dom is the same *)
+ Hashtbl.clear con.transactions;
+ con.next_tid <- initial_next_tid;
+ Hashtbl.clear con.watches;
+ (* anonid is the same *)
+ con.nb_watches <- 0;
+ con.stat_nb_ops <- 0;
+ (* perm is the same *)
+ ()
let get_path con =
-Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d ->
Domain.get_id d)
+ Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d ->
Domain.get_id d)
let watch_create ~con ~path ~token = {
- con = con;
- token = token;
- path = path;
- base = get_path con;
- is_relative = path.[0] <> '/' && path.[0] <> '@';
- pending_watchevents = BoundedPipe.create
~capacity:!Define.maxwatchevents ~destination:(Xenbus.Xb.queue con.xb)
+ con = con;
+ token = token;
+ path = path;
+ base = get_path con;
+ is_relative = path.[0] <> '/' && path.[0] <> '@';
+ pending_watchevents = BoundedPipe.create ~capacity:!Define.maxwatchevents
~destination:(Xenbus.Xb.queue con.xb)
}
|
 |
Lists.xenproject.org is hosted with RackSpace, monitoring our |