# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
# Date 1262958466 0
# Node ID 67078f88291e9970dc3ca0c43ae3ba28c8c20a0a
# Parent 90fd186e17ef6bc1193681c157a6fa683be7b668
[rpc-light] Add a function to marshal and unmarshal XMLRPC to a bigbuffer
Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
diff -r 90fd186e17ef -r 67078f88291e rpc-light/xmlrpc.ml
--- a/rpc-light/xmlrpc.ml Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/xmlrpc.ml Fri Jan 08 13:47:46 2010 +0000
@@ -77,6 +77,11 @@
add_value (Buffer.add_string buf) x;
Buffer.contents buf
+let to_a ~empty ~append x =
+ let buf = empty () in
+ add_value (fun s -> append buf s) x;
+ buf
+
let string_of_call call =
let module B = Buffer in
let buf = B.create 1024 in
@@ -102,6 +107,15 @@
add (to_string v);
add "</param></params></methodResponse>";
B.contents buf
+
+let a_of_response ~empty ~append response =
+ let buf = empty () in
+ let add s = append buf s in
+ let v = if response.success then response.contents else Dict [
"failure", response.contents ] in
+ add "<?xml version=\"1.0\"?><methodResponse><params><param>";
+ add (to_string v);
+ add "</param></params></methodResponse>";
+ buf
exception Parse_error of string * Xmlm.signal * Xmlm.input
@@ -141,8 +155,10 @@
aux [];
Buffer.contents buf
+let pretty_string_of_error (n,s,i) =
+ Printf.sprintf "Error: got '%s' while '%s' was expected when processing
'%s'\n" (debug_signal s) n (debug_input i)
+
let parse_error n s i =
- Printf.eprintf "Error: got '%s' while '%s' was expected when processing
'%s'\n" (debug_signal s) n (debug_input i);
raise (Parse_error (n,s,i))
module Parser = struct
@@ -153,9 +169,13 @@
| `Data d -> d
| e -> parse_error "..." e input
- let open_tag input =
+ let rec open_tag input =
match Xmlm.input input with
| `El_start ((_,tag),_) -> tag
+ | `Data s
+ when s = " "
+ || s = "\n"
+ || s = "\t" -> open_tag input
| e -> parse_error "<...>" e input
let close_tag input =
@@ -241,7 +261,16 @@
| `Dtd _ -> ignore (Xmlm.input input)
| _ -> () end;
Parser.of_xml ?callback [] input
-
+
+let of_a ?callback ~next_char b =
+ let aux () =
+ try
+ let c = next_char b in
+ int_of_char c
+ with _ -> raise End_of_file in
+ let input = Xmlm.make_input (`Fun aux) in
+ Parser.of_xml ?callback [] input
+
let call_of_string ?callback str =
let input = Xmlm.make_input (`String (0, str)) in
begin match Xmlm.peek input with
diff -r 90fd186e17ef -r 67078f88291e rpc-light/xmlrpc.mli
--- a/rpc-light/xmlrpc.mli Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/xmlrpc.mli Fri Jan 08 13:47:46 2010 +0000
@@ -15,10 +15,14 @@
val to_string : Rpc.t -> string
val of_string : ?callback:Rpc.callback -> string -> Rpc.t
+val to_a : empty:(unit -> 'a) -> append:('a -> string -> unit) -> Rpc.t -> 'a
+val of_a : ?callback:Rpc.callback -> next_char:('a -> char) -> 'a -> Rpc.t
+
val string_of_call: Rpc.call -> string
val call_of_string: ?callback:Rpc.callback -> string -> Rpc.call
val string_of_response: Rpc.response -> string
+val a_of_response : empty:(unit -> 'a) -> append:('a -> string -> unit) ->
Rpc.response -> 'a
val response_of_string: ?callback:Rpc.callback -> string -> Rpc.response
val response_of_in_channel: ?callback:Rpc.callback -> in_channel ->
Rpc.response
2 files changed, 36 insertions(+), 3 deletions(-)
rpc-light/xmlrpc.ml | 35 ++++++++++++++++++++++++++++++++---
rpc-light/xmlrpc.mli | 4 ++++
xen-api-libs.hg-17.patch
Description: Text Data
_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api
|
Home