Source file oBus_introspect.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
open OBus_xml_parser
type name = string
type annotation = name * string
type argument = name option * OBus_value.T.single
type access = Read | Write | Read_write
type member =
| Method of name * argument list * argument list * annotation list
| Signal of name * argument list * annotation list
| Property of name * OBus_value.T.single * access * annotation list
type interface = name * member list * annotation list
type node = OBus_path.element
type document = interface list * node list
exception Parse_failure = OBus_xml_parser.Parse_failure
let () =
Printexc.register_printer
(function
| Parse_failure((line, column), msg) ->
Some(Printf.sprintf "failed to parse D-Bus introspection document, at line %d, column %d: %s" line column msg)
| _ ->
None)
let annotations p =
any p (elt "annotation"
(fun p ->
let name = ar p "name" in
let value = ar p "value" in
(name, value)))
type direction = In | Out
let atype p =
let signature = ar p "type" in
match OBus_value.signature_of_string signature with
| [] -> failwith p "empty signature"
| [t] -> t
| _ -> Printf.ksprintf (failwith p) "this signature contains more than one single type: %S" signature
let arguments p =
any p (elt "arg"
(fun p ->
let name = ao p "name" in
let dir = afd p "direction" In [("in", In); ("out", Out)] in
let typ = atype p in
(dir, (name, typ))))
let mk_aname test p =
let name = ar p "name" in
match test name with
| Some error -> failwith p (OBus_string.error_message error)
| None -> name
let amember = mk_aname OBus_name.validate_member
let anode = mk_aname OBus_path.validate_element
let ainterface = mk_aname OBus_name.validate_interface
let method_decl =
elt "method"
(fun p ->
let name = amember p in
let args = arguments p in
let ins, outs =
OBus_util.split
(function
| (In, x) -> OBus_util.InL x
| (Out, x) -> OBus_util.InR x)
args
in
let annots = annotations p in
(Method(name, ins, outs, annots)))
let signal_decl =
elt "signal"
(fun p ->
let name = amember p in
let args = arguments p in
let annots = annotations p in
(Signal(name, List.map snd args, annots)))
let property_decl =
elt "property"
(fun p ->
let name = amember p in
let access = afr p "access" [("read", Read); ("write", Write); ("readwrite", Read_write)] in
let typ = atype p in
let annots = annotations p in
(Property(name, typ, access, annots)))
let node =
elt "node" (fun p ->
let name = anode p in
match OBus_path.validate_element name with
| None -> name
| Some error -> failwith p (OBus_string.error_message { error with OBus_string.typ = "node name" }))
let interface =
elt "interface"
(fun p ->
let name = ainterface p in
let decls = any p (union [method_decl;
signal_decl;
property_decl]) in
let annots = annotations p in
(name, decls, annots))
let document =
elt "node"
(fun p ->
let interfs = any p interface in
let subs = any p node in
(interfs, subs))
let input xi = OBus_xml_parser.input xi document
type xml = Element of string * (string * string) list * xml list
let to_xml (ifaces, nodes) =
let pannots = List.map (fun (n, v) -> Element("annotation", [("name", n); ("value", v)], [])) in
let pargs dir = List.map (fun (n, t) ->
let attrs = [("type", OBus_value.string_of_signature [t])] in
let attrs = match dir with
| Some In -> ("direction", "in") :: attrs
| Some Out -> ("direction", "out") :: attrs
| None -> attrs in
let attrs = match n with
| Some n -> ("name", n) :: attrs
| None -> attrs in
Element("arg", attrs, [])) in
Element("node", [],
List.map (fun (name, content, annots) ->
Element("interface", [("name", name)],
pannots annots
@ List.map
(function
| Method(name, ins, outs, annots) ->
Element("method", [("name", name)],
pargs (Some In) ins
@ pargs (Some Out) outs
@ pannots annots)
| Signal(name, args, annots) ->
Element("signal", [("name", name)],
pargs None args
@ pannots annots)
| Property(name, typ, access, annots) ->
Element("property",
[("name", name);
("type", OBus_value.string_of_signature [typ]);
("access", match access with
| Read -> "read"
| Write -> "write"
| Read_write -> "readwrite")],
pannots annots))
content)) ifaces
@ List.map (fun n -> Element("node", [("name", n)], [])) nodes)
let output xo doc =
let rec aux (Element(name, attrs, children)) =
Xmlm.output xo (`El_start(("", name), List.map (fun (name, value) -> (("", name), value)) attrs));
List.iter aux children;
Xmlm.output xo `El_end
in
Xmlm.output xo (`Dtd(Some "<!DOCTYPE node PUBLIC \"-//freedesktop//DTD D-BUS Object Introspection 1.0//EN\"\n\
\"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd\">"));
aux (to_xml doc)
let deprecated = "org.freedesktop.DBus.Deprecated"
let csymbol = "org.freedesktop.DBus.GLib.CSymbol"
let no_reply = "org.freedesktop.DBus.Method.NoReply"
let emits_changed_signal = "org.freedesktop.DBus.Property.EmitsChangedSignal"