1 (* Memory info command for virtual domains.
2 (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25 let (//) = Filename.concat
27 type pathname = string
30 kernel_version : string;
37 struct_total_size : int;
38 struct_fields : field list;
49 | FStructPointer of string
55 let string_of_info i =
56 sprintf "%s: %s %s" i.basename i.kernel_version i.arch
58 let rec string_of_structure s =
59 let fields = List.map string_of_field s.struct_fields in
60 let fields = String.concat "\n " fields in
61 sprintf "struct %s {\n %s\n}; /* total size = %d bytes */"
62 s.struct_name fields s.struct_total_size
64 and string_of_field f =
65 sprintf "%s %s; /* offset = %d, size = %d */"
66 f.field_name (string_of_f_type f.field_type)
67 f.field_offset f.field_size
69 and string_of_f_type = function
70 | FStructPointer struct_name -> sprintf "struct %s*" struct_name
71 | FVoidPointer -> "void *"
72 | FListHeadPointer -> "struct list_head *"
74 | FString width -> sprintf "char[%d]" width
76 (* Regular expressions. We really really should use ocaml-mikmatch ... *)
77 let re_oldformat = Pcre.regexp "^RPM: \\d+: \\(build \\d+\\) ([-\\w]+) ([\\w.]+) ([\\w.]+) \\(.*?\\) (\\w+)"
78 let re_keyvalue = Pcre.regexp "^(\\w+): (.*)"
80 let list_kernels path =
81 (* Get the *.info files from the kernels database. *)
82 let infos = Sys.readdir path in
83 let infos = Array.to_list infos in
84 let infos = List.filter (fun name -> String.ends_with name ".info") infos in
85 let infos = List.map ( (//) path) infos in
87 (* Parse in the *.info files. These have historically had a few different
88 * formats that we need to support.
90 let infos = List.map (
92 (* Get the basename (for getting the .data file later on). *)
93 let basename = Filename.chop_suffix filename ".info" in
95 let chan = open_in filename in
96 let line = input_line chan in
98 (* Kernel version string. *)
100 if Pcre.pmatch ~rex:re_oldformat line then (
101 (* If the file starts with "RPM: \d+: ..." then it's the
102 * original Fedora format. Everything in one line.
104 let subs = Pcre.exec ~rex:re_oldformat line in
105 (* let name = Pcre.get_substring subs 1 in *)
106 let version = Pcre.get_substring subs 2 in
107 let release = Pcre.get_substring subs 3 in
108 let arch = Pcre.get_substring subs 4 in
110 (* XXX Map name -> PAE, hugemem etc. *)
111 (* name, *) sprintf "%s-%s.%s" version release arch, arch
113 (* New-style "key: value" entries, up to end of file or the first
116 let (*name,*) version, release, arch =
117 (*ref "",*) ref "", ref "", ref "" in
120 let subs = Pcre.exec ~rex:re_keyvalue line in
121 let key = Pcre.get_substring subs 1 in
122 let value = Pcre.get_substring subs 2 in
123 (*if key = "Name" then name := value
124 else*) if key = "Version" then version := value
125 else if key = "Release" then release := value
126 else if key = "Architecture" then arch := value;
127 let line = input_line chan in
130 Not_found | End_of_file ->
134 let (*name,*) version, release, arch =
135 (*!name,*) !version, !release, !arch in
136 if (*name = "" ||*) version = "" || release = "" || arch = "" then
137 failwith (sprintf "%s: missing Name, Version, Release or Architecture key" filename);
138 (* XXX Map name -> PAE, hugemem etc. *)
139 (* name, *) sprintf "%s-%s.%s" version release arch, arch
142 (*printf "%s -> %s %s\n%!" basename version arch;*)
144 { basename = basename; arch = arch;
145 kernel_version = version }
149 (* XXX This would be better as a proper lex/yacc parser.
150 * XXX Even better would be to have a proper interface to libdwarves.
152 let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/"
153 let re_intfield = Pcre.regexp "(?:int|char)\\s+(\\w+);"
154 let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);"
155 let re_voidptrfield = Pcre.regexp "void\\s*\\*\\s*(\\w+);"
156 let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];"
157 let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$"
158 let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;"
160 let load_structures { basename = basename } struct_names =
161 (* For quick access to the opener strings, build a hash. *)
162 let openers = Hashtbl.create 13 in
165 let opener = sprintf "struct %s {" struct_name in
167 Hashtbl.add openers opener (closer, struct_name)
170 (* Now read the data file and parse out the structures of interest. *)
171 let file_exists name =
172 try Unix.access name [Unix.F_OK]; true
173 with Unix.Unix_error _ -> false
175 let close_process_in cmd chan =
176 match Unix.close_process_in chan with
177 | Unix.WEXITED 0 -> ()
179 eprintf "%s: command exited with code %d\n" cmd i; exit i
180 | Unix.WSIGNALED i ->
181 eprintf "%s: command exited with signal %d\n" cmd i; exit 1
183 eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
186 (* Open the data file, uncompressing it on the fly if necessary. *)
188 if file_exists (basename ^ ".data") then
189 open_in (basename ^ ".data"), close_in
190 else if file_exists (basename ^ ".data.gz") then (
192 sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
193 Unix.open_process_in cmd, close_process_in cmd
195 else if file_exists (basename ^ ".data.bz2") then (
197 sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
198 Unix.open_process_in cmd, close_process_in cmd
200 failwith (sprintf "%s: cannot find corresponding data file" basename) in
202 (* Read the data file in, looking for structures of interest to us. *)
203 let bodies = Hashtbl.create 13 in
205 let line = input_line chan in
207 (* If the line is an opener for one of the structures we
208 * are looking for, then for now just save all the text until
209 * we get to the closer line.
212 let closer, struct_name = Hashtbl.find openers line in
213 let rec loop2 lines =
214 let line = input_line chan in
215 let lines = line :: lines in
216 if String.starts_with line closer then List.rev lines
223 failwith (sprintf "%s: %s: %S not matched by closing %S" basename struct_name line closer) in
225 Hashtbl.replace bodies struct_name body
226 with Not_found -> ());
230 (try loop () with End_of_file -> ());
234 (* Now parse each structure body. *)
236 (* 'basename' is the source file, and second parameter ('body') is
237 * the list of text lines which covers this structure (minus the
238 * opener line). Result is the list of parsed fields from this
241 let rec parse basename = function
243 | [_] -> [] (* Just the closer line, finished. *)
244 | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
245 (* Recursively parse a sub-structure. First search for the
246 * corresponding closer line.
248 let rec loop depth acc = function
250 eprintf "%s: %S has no matching close structure line\n%!"
253 | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
254 loop (depth+1) (line :: acc) lines
256 when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
259 when depth > 0 && Pcre.pmatch ~rex:re_structcloser line ->
260 loop (depth-1) (line :: acc) lines
261 | line :: lines -> loop depth (line :: acc) lines
263 let nested_body, rest = loop 0 [] lines in
265 (* Then parse the sub-structure. *)
266 let struct_name, nested_body =
267 match nested_body with
270 let subs = Pcre.exec ~rex:re_structcloser closer in
272 try Some (Pcre.get_substring subs 1) with Not_found -> None in
273 struct_name, List.rev nested_body in
274 let nested_fields = parse basename nested_body in
276 (* Prefix the sub-fields with the name of the structure. *)
278 match struct_name with
279 | None -> nested_fields
282 fun ({ field_name = name } as field) ->
283 let name = prefix ^ "'" ^ name in
284 { field with field_name = name }
287 (* Parse the rest. *)
288 nested_fields @ parse basename rest
290 | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
292 let subs = Pcre.exec ~rex:re_intfield line in
293 let name = Pcre.get_substring subs 1 in
295 let subs = Pcre.exec ~rex:re_offsetsize line in
296 let offset = int_of_string (Pcre.get_substring subs 1) in
297 let size = int_of_string (Pcre.get_substring subs 2) in
299 { field_name = name; field_type = FInteger;
300 field_offset = offset; field_size = size } in
301 field :: parse basename lines
303 Not_found -> parse basename lines
306 | line :: lines when Pcre.pmatch ~rex:re_ptrfield line ->
307 (* A pointer-to-struct field. *)
308 let subs = Pcre.exec ~rex:re_ptrfield line in
309 let struct_name = Pcre.get_substring subs 1 in
310 let name = Pcre.get_substring subs 2 in
312 let subs = Pcre.exec ~rex:re_offsetsize line in
313 let offset = int_of_string (Pcre.get_substring subs 1) in
314 let size = int_of_string (Pcre.get_substring subs 2) in
316 if struct_name <> "list_head" then
317 FStructPointer struct_name
321 { field_name = name; field_type = field_type;
322 field_offset = offset; field_size = size } in
323 field :: parse basename lines
325 Not_found -> parse basename lines
328 | line :: lines when Pcre.pmatch ~rex:re_voidptrfield line ->
330 let subs = Pcre.exec ~rex:re_voidptrfield line in
331 let name = Pcre.get_substring subs 1 in
333 let subs = Pcre.exec ~rex:re_offsetsize line in
334 let offset = int_of_string (Pcre.get_substring subs 1) in
335 let size = int_of_string (Pcre.get_substring subs 2) in
337 { field_name = name; field_type = FVoidPointer;
338 field_offset = offset; field_size = size } in
339 field :: parse basename lines
341 Not_found -> parse basename lines
344 | line :: lines when Pcre.pmatch ~rex:re_strfield line ->
345 (* A string (char array) field. *)
346 let subs = Pcre.exec ~rex:re_strfield line in
347 let name = Pcre.get_substring subs 1 in
348 let width = int_of_string (Pcre.get_substring subs 2) in
350 let subs = Pcre.exec ~rex:re_offsetsize line in
351 let offset = int_of_string (Pcre.get_substring subs 1) in
352 let size = int_of_string (Pcre.get_substring subs 2) in
354 { field_name = name; field_type = FString width;
355 field_offset = offset; field_size = size } in
356 field :: parse basename lines
358 Not_found -> parse basename lines
362 (* Just ignore any other field we can't parse. *)
366 let structures = List.filter_map (
369 try Some (Hashtbl.find bodies struct_name)
370 with Not_found -> None in
374 let body = List.tl body in (* Don't care about opener line. *)
375 let fields = parse basename body in
377 (* Compute total size of the structure. *)
379 let fields = List.map (
380 fun { field_offset = offset;
381 field_size = size } -> offset + size
383 List.fold_left max 0 fields in
385 Some { struct_name = struct_name;
386 struct_fields = fields;
387 struct_total_size = total_size }