(*
* Copyright (c) 2001 by Michael Neumann
*
* this program parses a XML-RPC document
*
* $Id: parser.ml,v 1.1 2001/07/26 08:56:40 michael Exp $
*)
open Pxp_yacc;;
open Pxp_types;;
open Pxp_document;;
(* XML file to load *)
let filename = "methodresponse.xml";;
(*let filename = "methodcall.xml";;*)
type xmlrpc_value =
X_String of string
| X_Integer of int
| X_Boolean of bool
| X_Double of float
| X_Base64 of string
| X_Array of xmlrpc_value list
| X_Struct of (string * xmlrpc_value) list
| X_DateTime_iso8601 of string
;;
type xmlrpc_valtype = XV_Value | XV_Fault ;;
type xmlrpc_type = XT_Call | XT_Response | XT_None ;;
exception Wrong_boolean;;
exception Wrong_struct;;
(* returns the #PCDATA string of the child of node `n` *)
let get_sub_data n =
let children = n # sub_nodes in
(List.hd children) # data
;;
(*
* applies function `fct` on all elements in list `lst`
* and give the result of that call as parameter of the
* next call to the next element of the list and so on.
*)
let rec apply_children lst fct value =
match lst with
hd :: tl -> apply_children tl fct (fct hd value)
| [] -> value
;;
(* parses the node `node` *)
let rec parse node (typ, valtype, name, params) =
match node # node_type with
T_element "methodCall" ->
let children = node # sub_nodes in
apply_children children parse (XT_Call, XV_Value, name, params)
| T_element "methodResponse" ->
let children = node # sub_nodes in
apply_children children parse (XT_Response, XV_Value, name, params)
| T_element "fault" ->
let children = node # sub_nodes in
apply_children children parse (typ, XV_Fault, name, params)
| T_element ("methodName" | "name") ->
(typ, valtype, get_sub_data node, params)
| T_element "string" ->
(typ, valtype, name, params @ [X_String (get_sub_data node)])
| T_element ("int" | "i4") ->
(typ, valtype, name, params @ [X_Integer (int_of_string (get_sub_data node))])
| T_element "boolean" ->
let boolean = int_of_string (get_sub_data node) in (
match boolean with
0 | 1 -> (typ, valtype, name, params @ [X_Boolean (boolean=1)])
| n -> raise Wrong_boolean
)
| T_element "double" ->
(typ, valtype, name, params @ [X_Double (float_of_string (get_sub_data node))])
| T_element "base64" ->
(typ, valtype, name, params @ [X_Base64 (get_sub_data node)])
(* TODO: decode *)
| T_element "dateTime.iso8601" ->
(typ, valtype, name, params @ [X_DateTime_iso8601 (get_sub_data node)])
(* TODO: decode *)
| T_element "array" ->
let children = node # sub_nodes in
let (_,_,_,arr) = apply_children children parse (typ,valtype,"", []) in
(typ, valtype, name, params @ [X_Array arr])
| T_element "struct" ->
let children = node # sub_nodes in
(* important because element can also be #PCDATA when in non-validating mode! *)
let mem_children = List.filter (fun e -> match e # node_type with T_element "member" -> true | _ -> false) children in
let members = List.map (fun ele ->
let (_,_,name,value) = parse ele (typ,valtype,"",[]) in
match value with
value::[] -> (name,value)
| _ -> raise Wrong_struct
) mem_children in
(typ, valtype, name, params @ [X_Struct members])
| T_data ->
let t = (typ, valtype, name, params) in
(match node # parent # node_type with
T_element "value" ->
if List.length (node # parent # sub_nodes) = 1 then
(typ, valtype, name, params @ [X_String (node # data)])
else t
| _ -> t)
| _ ->
let children = node # sub_nodes in
apply_children children parse (typ, valtype, name, params)
;;
(* outputs a value of type `xmlrpc_value` *)
let rec output_argument ele =
match ele with
X_String s -> print_endline s
| X_Integer i -> print_int i; print_newline ()
| X_Boolean b -> if b then print_endline "true" else print_endline "false"
| X_Double d -> print_float d; print_newline ()
| X_Base64 s -> print_endline s
| X_Array a -> List.iter (fun v -> print_string " "; output_argument v) a
| X_Struct s -> List.iter (fun (n,v) -> print_string (" " ^ n ^ " ==> "); output_argument v) s
| X_DateTime_iso8601 d -> print_endline d
;;
(*let xmlrpc_parse filename*)
let d = parse_document_entity default_config (from_file filename) default_spec in
let (typ, valtype, name, args) = parse (d # root) (XT_None, XV_Value, "", []) in
print_endline ("methName: " ^ name);
List.iter output_argument args
;;