# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
# Date 1262958466 0
# Node ID 8e5e1af38c22077f98510231918d83ff5c715e05
# Parent 91091e97839df807f73ddbd9ff40ab1e13d7753d
[rpc-light] Add some explicit runtime exceptions when an runtime error occurs.
A friendly error message is displayed as well if Rpc.set_debug true is called
before.
Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
diff -r 91091e97839d -r 8e5e1af38c22 rpc-light/p4_rpc.ml
--- a/rpc-light/p4_rpc.ml Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/p4_rpc.ml Fri Jan 08 13:47:46 2010 +0000
@@ -103,7 +103,6 @@
let new_id_list _loc l =
List.split (List.map (fun _ -> new_id _loc) l)
-exception Type_not_supported of ctyp
let type_not_supported ty =
let module PP = Camlp4.Printers.OCaml.Make(Syntax) in
let pp = new PP.printer () in
@@ -216,121 +215,126 @@
let str_of_id id = match id with <:expr@loc< $lid:s$ >> -> <:expr@loc<
$str:s$ >> | _ -> assert false
- let runtime_error id expected =
+ let runtime_error name id expected =
let _loc = Loc.ghost in
- <:match_case< __x__ ->
- failwith (Printf.sprintf "Runtime error while parsing
'%s': got '%s' while '%s' was expected\\n" $str_of_id id$ (Rpc.to_string __x__)
$str:expected$)
+ <:match_case< __x__ -> do {
+ if Rpc.get_debug () then
+ Printf.eprintf "Runtime error in
'%s_of_rpc:%s': got '%s' when '%s' was expected\\n" $str:name$ $str_of_id id$
(Rpc.to_string __x__) $str:expected$
+ else ();
+ raise (Rpc.Runtime_error ($str:expected$, __x__)) }
>>
- let runtime_exn_error id doing =
+ let runtime_exn_error name id doing =
let _loc = Loc.ghost in
- <:match_case< __x__ ->
- failwith (Printf.sprintf "Runtime error while parsing
'%s': got exception '%s' while doing '%s'\\n" $str_of_id id$
(Printexc.to_string __x__) $str:doing$)
- >>
+ <:match_case< __x__ -> do {
+ if Rpc.get_debug () then
+ Printf.eprintf "Runtime error in
'%s_of_rpc:%s': caught exception '%s' while doing '%s'\\n" $str:name$
$str_of_id id$ (Printexc.to_string __x__) $str:doing$
+ else () ;
+ raise (Rpc.Runtime_exception ($str:doing$,
Printexc.to_string __x__)) } >>
- let rec create id ctyp =
+ let rec create name id ctyp =
let _loc = loc_of_ctyp ctyp in
match ctyp with
- | <:ctyp< unit >> -> <:expr< match $id$ with [ Rpc.Null -> ()
| $runtime_error id "Null"$ ] >>
+ | <:ctyp< unit >> -> <:expr< match $id$ with [ Rpc.Null -> ()
| $runtime_error name id "Null"$ ] >>
| <:ctyp< int >> ->
<:expr< match $id$ with [
Rpc.Int x -> Int64.to_int x
| Rpc.String s -> int_of_string s
- | $runtime_error id "Int(int)"$ ] >>
+ | $runtime_error name id "Int(int)"$ ] >>
| <:ctyp< int32 >> ->
<:expr< match $id$ with [
Rpc.Int x -> Int64.to_int32 x
| Rpc.String s -> Int32.of_string s
- | $runtime_error id "Int(int32)"$ ] >>
+ | $runtime_error name id "Int(int32)"$ ] >>
| <:ctyp< int64 >> ->
<:expr< match $id$ with [
Rpc.Int x -> x
| Rpc.String s -> Int64.of_string s
- | $runtime_error id "Int(int64)"$ ] >>
+ | $runtime_error name id "Int(int64)"$ ] >>
| <:ctyp< float >> ->
<:expr< match $id$ with [
Rpc.Float x -> x
| Rpc.String s -> float_of_string s
- | $runtime_error id "Float"$ ] >>
+ | $runtime_error name id "Float"$ ] >>
| <:ctyp< char >> ->
<:expr< match $id$ with [
Rpc.Int x -> Char.chr (Int64.to_int x)
| Rpc.String s -> Char.chr (int_of_string s)
- | $runtime_error id "Int(char)"$ ] >>
+ | $runtime_error name id "Int(char)"$ ] >>
- | <:ctyp< string >> -> <:expr< match $id$ with [ Rpc.String x
-> x | $runtime_error id "String(string)"$ ] >>
- | <:ctyp< bool >> -> <:expr< match $id$ with [ Rpc.Bool x ->
x | $runtime_error id "Bool"$ ] >>
+ | <:ctyp< string >> -> <:expr< match $id$ with [ Rpc.String x
-> x | $runtime_error name id "String(string)"$ ] >>
+ | <:ctyp< bool >> -> <:expr< match $id$ with [ Rpc.Bool x ->
x | $runtime_error name id "Bool"$ ] >>
| <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ]
>> | <:ctyp< [ $t$ ] >> ->
let ids, ctyps = decompose_variants _loc t in
let pattern (n, t) ctyps =
let ids, pids = new_id_list _loc ctyps in
let patt = <:patt< Rpc.Enum [ Rpc.String
$str:n$ :: $patt_list_of_list _loc pids$ ] >> in
- let exprs = List.map2 create ids ctyps in
+ let exprs = List.map2 (create name) ids ctyps in
let body = List.fold_right
(fun a b -> <:expr< $b$ $a$ >>)
(List.rev exprs)
(if t = `V then <:expr< $uid:n$ >> else
<:expr< `$uid:n$ >>) in
<:match_case< $patt$ -> $body$ >> in
- let fail_match = <:match_case< $runtime_error id
"Enum[String s;...]"$ >> in
+ let fail_match = <:match_case< $runtime_error name id
"Enum[String s;...]"$ >> in
let patterns = mcOr_of_list (List.map2 pattern ids
ctyps @ [ fail_match ]) in
<:expr< match $id$ with [ $patterns$ ] >>
| <:ctyp< option $t$ >> ->
let nid, npid = new_id _loc in
- <:expr< match $id$ with [ Rpc.Enum [] -> None |
Rpc.Enum [ $npid$ ] -> Some $create nid t$ | $runtime_error id
"Enum[]/Enum[_]"$ ] >>
+ <:expr< match $id$ with [ Rpc.Enum [] -> None |
Rpc.Enum [ $npid$ ] -> Some $create name nid t$ | $runtime_error name id
"Enum[]/Enum[_]"$ ] >>
| <:ctyp< $tup:tp$ >> ->
let ctyps = list_of_ctyp tp [] in
let ids, pids = new_id_list _loc ctyps in
- let exprs = List.map2 create ids ctyps in
+ let exprs = List.map2 (create name) ids ctyps in
<:expr< match $id$ with
- [ Rpc.Enum $patt_list_of_list _loc pids$ ->
$expr_tuple_of_list _loc exprs$ | $runtime_error id "List"$ ]
+ [ Rpc.Enum $patt_list_of_list _loc pids$ ->
$expr_tuple_of_list _loc exprs$ | $runtime_error name id "List"$ ]
>>
| <:ctyp< list $t$ >> ->
let nid, npid = new_id _loc in
let nid2, npid2 = new_id _loc in
<:expr< match $id$ with
- [ Rpc.Enum $npid$ -> List.map (fun $npid2$ ->
$create nid2 t$) $nid$ | $runtime_error id "List"$ ]
+ [ Rpc.Enum $npid$ -> List.map (fun $npid2$ ->
$create name nid2 t$) $nid$ | $runtime_error name id "List"$ ]
>>
| <:ctyp< array $t$ >> ->
let nid, npid = new_id _loc in
let nid2, npid2 = new_id _loc in
<:expr< match $id$ with
- [ Rpc.Enum $npid$ -> Array.of_list (List.map
(fun $npid2$ -> $create nid2 t$) $nid$) | $runtime_error id "List"$ ]
+ [ Rpc.Enum $npid$ -> Array.of_list (List.map
(fun $npid2$ -> $create name nid2 t$) $nid$) | $runtime_error name id "List"$ ]
>>
| <:ctyp< { $t$ } >> ->
let nid, npid = new_id _loc in
let fields = decompose_fields _loc t in
let ids, pids = new_id_list _loc fields in
- let exprs = List.map2 (fun id (n, ctyp) ->
<:rec_binding< $lid:n$ = $create id ctyp$ >>) ids fields in
+ let exprs = List.map2 (fun id (n, ctyp) ->
<:rec_binding< $lid:n$ = $create name id ctyp$ >>) ids fields in
let bindings =
List.map2 (fun pid (n, ctyp) ->
- <:binding< $pid$ = try List.assoc
$str:n$ $nid$ with [ $runtime_exn_error nid ("Looking for key "^n)$ ] >>
+ <:binding< $pid$ = try List.assoc
$str:n$ $nid$ with [ $runtime_exn_error name nid ("Looking for key "^n)$ ] >>
) pids fields in
<:expr< match $id$ with
- [ Rpc.Dict $npid$ -> let $biAnd_of_list
bindings$ in { $rbSem_of_list exprs$ } | $runtime_error id "Dict"$ ]
+ [ Rpc.Dict $npid$ -> let $biAnd_of_list
bindings$ in { $rbSem_of_list exprs$ } | $runtime_error name id "Dict"$ ]
>>
| <:ctyp< < $t$ > >> ->
let nid, npid = new_id _loc in
let fields = decompose_fields _loc t in
let ids, pids = new_id_list _loc fields in
- let exprs = List.map2 (fun id (n, ctyp) ->
<:class_str_item< method $lid:n$ = $create id ctyp$ >>) ids fields in
+ let exprs = List.map2 (fun id (n, ctyp) ->
<:class_str_item< method $lid:n$ = $create name id ctyp$ >>) ids fields in
let bindings =
List.map2 (fun pid (n, ctyp) ->
- <:binding< $pid$ = try List.assoc
$str:n$ $nid$ with [ $runtime_exn_error nid ("Looking for key "^n)$ ] >>
+ <:binding< $pid$ = try List.assoc
$str:n$ $nid$ with [ $runtime_exn_error name nid ("Looking for key "^n)$ ] >>
) pids fields in
<:expr< match $id$ with
- [ Rpc.Dict $npid$ -> let $biAnd_of_list
bindings$ in object $crSem_of_list exprs$ end | $runtime_error id "Dict"$ ]
+ [ Rpc.Dict $npid$ -> let $biAnd_of_list
bindings$ in object $crSem_of_list exprs$ end | $runtime_error name id "Dict"$ ]
>>
| <:ctyp< '$lid:a$ >> -> <:expr<
$lid:of_rpc_polyvar a$ $id$ >>
@@ -338,8 +342,8 @@
| <:ctyp< $lid:t$ >> -> <:expr< $lid:of_rpc t$
$id$ >>
| <:ctyp< $id:m$ . $lid:t$ >> -> <:expr< $id:m$ .
$lid:of_rpc t$ $id$ >>
- | <:ctyp< $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i
create id None t a
- | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i
create id (Some m) t a
+ | <:ctyp< $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i
(create name) id None t a
+ | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i
(create name) id (Some m) t a
| _ -> type_not_supported ctyp
@@ -349,7 +353,7 @@
<:binding< $lid:of_rpc name$ =
$List.fold_left
(fun accu arg -> <:expr< fun
$lid:of_rpc_polyvar (name_of_polyvar _loc arg)$ -> $accu$ >>)
- (<:expr< fun $pid$ -> $create id ctyp$ >>)
+ (<:expr< fun $pid$ -> $create name id ctyp$ >>)
args$
>>
diff -r 91091e97839d -r 8e5e1af38c22 rpc-light/rpc.ml
--- a/rpc-light/rpc.ml Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/rpc.ml Fri Jan 08 13:47:46 2010 +0000
@@ -12,6 +12,10 @@
* GNU Lesser General Public License for more details.
*)
+let debug = ref false
+let set_debug x = debug := x
+let get_debug () = !debug
+
type t =
| Int of int64
| Bool of bool
@@ -20,6 +24,9 @@
| Enum of t list
| Dict of (string * t) list
| Null
+
+exception Runtime_error of string * t
+exception Runtime_exception of string * string
open Printf
let map_strings sep fn l = String.concat sep (List.map fn l)
diff -r 91091e97839d -r 8e5e1af38c22 rpc-light/rpc.mli
--- a/rpc-light/rpc.mli Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/rpc.mli Fri Jan 08 13:47:46 2010 +0000
@@ -56,3 +56,12 @@
val success : t -> response
val failure : t -> response
+
+(** {2 Run-time errors} *)
+
+exception Runtime_error of string * t
+exception Runtime_exception of string * string
+
+(** {2 Debug options} *)
+val set_debug : bool -> unit
+val get_debug : unit -> bool
3 files changed, 53 insertions(+), 33 deletions(-)
rpc-light/p4_rpc.ml | 70 ++++++++++++++++++++++++++-------------------------
rpc-light/rpc.ml | 7 +++++
rpc-light/rpc.mli | 9 ++++++
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