Source file mopsa_build_db.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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
(**
Mopsa_build_db - Build a database to manage the analysis of multi-file projects
*)
let log = ref false
let logfile = ref (open_out "/dev/null")
(** {1 DB representation} *)
(** Version number.
This should be changed when the db type changes to avoid loading
old DB files.
*)
let version = "Mopsa.C.DB/1"
module StringMap = Map.Make(String)
(** Map with string key *)
type source_kind = SOURCE_C | SOURCE_CXX | SOURCE_ASM | SOURCE_UNKNOWN
let source_kind_name = function
| SOURCE_C -> "C"
| SOURCE_CXX -> "C++"
| SOURCE_ASM -> "assembly"
| SOURCE_UNKNOWN -> "unknown"
type source = {
source_path: string; (** absolute path of source file *)
source_obj: string; (** absolute path of the object file *)
source_kind: source_kind;
source_opts: string list; (** compilation options *)
source_cwd: string; (** directory from where the compilation was launched *)
}
(** a compiled source *)
let source_unknown (path:string) = {
source_path = path;
source_obj = path;
source_kind = SOURCE_UNKNOWN;
source_opts = [];
source_cwd = Sys.getcwd();
}
module SourceSet = Set.Make(struct type t=source let compare=compare end)
type library_kind = LIBRARY_STATIC | LIBRARY_DYNAMIC
let library_kind_name = function
| LIBRARY_STATIC -> "static"
| LIBRARY_DYNAMIC -> "dynamic"
type file_kind =
| Object of source
| Library of library_kind * file StringMap.t (** contents, indexed by file name *)
| Executable of file list
| Unknown of string (** absolute path *)
and file = string (** absolute path *) * file_kind
type db = file StringMap.t (** indexed by absolute path *)
let empty_db = StringMap.empty
(** {1 Printing} *)
let rec print_file indent (name,kind) =
match kind with
| Object s ->
Printf.printf
"%sOBJECT %s source=%s args=" indent
(source_kind_name s.source_kind) s.source_path;
List.iter (fun l -> Printf.printf "%s;" l) s.source_opts;
Printf.printf " path=%s\n" s.source_cwd
| Library (k,contents) ->
Printf.printf
"%sLIBRARY %s %s\n" indent
(library_kind_name k) name;
StringMap.iter
(fun tag file ->
Printf.printf "%s%s\n" indent tag;
print_file (indent^" ") file
) contents
| Executable contents ->
Printf.printf "%sEXECUTABLE %s\n" indent name;
List.iter (fun file -> print_file (indent^" ") file) contents
| Unknown _ ->
Printf.printf "%sUNKNOWN %s\n" indent name
let print_db (db:db) =
StringMap.iter (fun _ -> print_file "") db
let print_list_json sep f ch = function
| [] -> ()
| [a] -> f ch a
| (a::rest) ->
f ch a;
List.iter (Printf.fprintf ch "%s%a" sep f) rest
let print_file_json (name,kind) =
Printf.printf " {\n \"filename\": \"%s\",\n" name;
(match kind with
| Object s ->
Printf.printf " \"type\": \"object\",\n";
Printf.printf " \"lang\": \"%s\",\n" (source_kind_name s.source_kind);
Printf.printf " \"source\": \"%s\",\n" (String.escaped s.source_path);
Printf.printf " \"args\": [%a],\n" (print_list_json ", " (fun ch l -> Printf.fprintf ch "\"%s\"" (String.escaped l))) s.source_opts;
Printf.printf " \"path\": \"%s\"\n" (String.escaped s.source_cwd)
| Library (k,contents) ->
Printf.printf " \"type\": \"library\",\n";
Printf.printf " \"kind\": \"%s\",\n" (library_kind_name k);
let cnt = StringMap.fold (fun _ (file,_) acc -> file::acc) contents [] in
Printf.printf " \"contents\": [%a]\n" (print_list_json ", " (fun ch tag -> Printf.printf "\"%s\"" (String.escaped tag))) (List.rev cnt);
| Executable contents ->
Printf.printf " \"type\": \"executable\",\n";
Printf.printf " \"contents\": [%a]\n" (print_list_json ", " (fun ch f -> Printf.printf "\"%s\"" (String.escaped (fst f)))) contents
| Unknown _ ->
Printf.printf " \"type\": \"unknown\"\n"
);
Printf.printf " }"
let print_db_json (db:db) =
let cnt = StringMap.fold (fun _ l acc -> l::acc) db [] in
Printf.printf "[";
print_list_json ",\n" (fun _ f -> print_file_json f) stdout (List.rev cnt);
Printf.printf "]"
(** {1 Utilities} *)
let starts_with pref s =
let pl,sl = String.length pref, String.length s in
(sl >= pl) && (String.sub s 0 pl = pref)
let ends_with suffix s =
let sxl,sl = String.length suffix, String.length s in
(sl >= sxl) && (String.sub s (sl - sxl) sxl = suffix)
let absolute_path name =
let name =
if Filename.is_relative name
then Filename.concat (Sys.getcwd()) name
else name
in
let rec normalize path =
let path, name = Filename.dirname path, Filename.basename path in
if name = path then path else
let path = normalize path in
if name = Filename.current_dir_name then path
else if name = Filename.parent_dir_name then Filename.dirname path
else Filename.concat path name
in
normalize name
(** {1 Apply file operations to DB} *)
(** recurse in directory *)
let get_files (db:db) (file:string) (recur:bool) : string list =
let file = absolute_path file in
if recur && Sys.file_exists file && Sys.is_directory file then
let file = Filename.concat file "" in
StringMap.fold
(fun k _ acc -> if starts_with file k then k::acc else acc)
db []
else
if StringMap.mem file db then [file]
else []
(** delete a file or directory *)
let db_remove (recur:bool) (db:db) (file:string) : db =
if !log then Printf.fprintf !logfile "DB: db_remove recur=%B file=%s\n%!" recur file;
let files = get_files db file recur in
List.fold_left
(fun db k ->
if !log then Printf.fprintf !logfile "DB: remove %s\n%!" k;
StringMap.remove k db
) db files
(** copy or move a file or directory *)
let db_copymove (move:bool) (recur:bool) (db:db) (org:string) (dest:string) : db =
if !log then Printf.fprintf !logfile "DB: db_copymove move=%B recur=%B org=%s dest=%s\n%!" move recur org dest;
let files = get_files db org recur in
let base = String.length (Filename.dirname (absolute_path org)) in
let dest = absolute_path dest in
let into = Sys.file_exists dest && Sys.is_directory dest in
List.fold_left
(fun db korg ->
let kdest =
if into
then dest^(String.sub korg base (String.length korg - base))
else dest
in
if !log then Printf.fprintf !logfile "DB: %s %s to %s\n%!" (if move then "move" else "copy") korg kdest;
let _,f = StringMap.find korg db in
let db = if move then StringMap.remove korg db else db in
StringMap.add kdest (kdest,f) db
) db files
(** create or add files to an archive *)
let db_add_archive (db:db) (archive:string) (kind:library_kind) (files: string list) : db =
let archive = absolute_path archive in
let contents =
try
match StringMap.find archive db
with _, Library (_,c) -> c | _ -> StringMap.empty
with Not_found -> StringMap.empty
in
let contents =
List.fold_left
(fun contents file ->
let key = Filename.basename file in
let file = absolute_path file in
let c =
try StringMap.find (absolute_path file) db
with Not_found -> file, Unknown file
in
if !log then Printf.fprintf !logfile "DB: add %s to archive %s as %s\n%!" file archive key;
StringMap.add key c contents
)
contents files
in
StringMap.add archive (archive, Library (kind,contents)) db
(** remove files from an archive *)
let db_remove_archive (db:db) (archive:string) (files: string list) : db =
let archive = absolute_path archive in
if StringMap.mem archive db then
match StringMap.find archive db with
| _, Library (kind, r) ->
let r =
List.fold_left
(fun r file ->
let key = Filename.basename file in
if !log then Printf.fprintf !logfile "DB: remove %s from archive %s\n%!" key archive;
StringMap.remove key r
)
r files in
StringMap.add archive (archive, Library (kind, r)) db
| _ -> db
else db
(** extract some files from an archive *)
let (db:db) (archive:string) (files: string list) : db =
let archive = absolute_path archive in
if StringMap.mem archive db then
match StringMap.find archive db with
| _, Library (kind, contents) ->
List.fold_left
(fun db f ->
let src = Filename.basename f
and dest = absolute_path f in
try
let _,v = StringMap.find src contents in
if !log then Printf.fprintf !logfile "DB: extract %s from archive %s as %s\n%!" src archive dest;
StringMap.add dest (dest,v) db
with Not_found -> db
)
db files
| _ -> db
else db
(** extract all files from an archive *)
let (db:db) (archive:string) : db =
let archive = absolute_path archive in
if StringMap.mem archive db then
match StringMap.find archive db with
| _, Library (kind, contents) ->
StringMap.fold
(fun tag (_,v) db ->
let dest = absolute_path tag in
if !log then Printf.fprintf !logfile "DB: extract %s from archive %s as %s\n%!" tag archive dest;
StringMap.add dest (dest,v) db
)
contents db
| _ -> db
else db
(** compile to object *)
let db_compile (db:db) (kind:source_kind) (src:string) (obj:string) (args: string list) =
let src = absolute_path src
and obj = absolute_path obj in
if !log then Printf.fprintf !logfile "DB: compile %s to %s\n%!" src obj;
let s =
{ source_kind = kind;
source_path = src;
source_obj = obj;
source_opts = args;
source_cwd = Sys.getcwd ();
}
in
StringMap.add obj (obj, Object s) db
(** link to executable *)
let db_link (db:db) (out:string) (files: string list) =
if files = [] then db
else
let out = absolute_path out in
let files = List.map absolute_path files in
let contents =
List.map
(fun file ->
try StringMap.find file db
with Not_found -> file, Unknown file
)
files
in
if !log then (
Printf.fprintf !logfile "DB: link executable %s\n%!" out;
List.iter (fun x -> Printf.fprintf !logfile "BD: adding %s\n%!" x) files
);
StringMap.add out (out, Executable contents) db
(** {1 DB loading, saving, locking} *)
let open_db ?(create=false) (dbfile:string) : Unix.file_descr =
let open Unix in
let flags = O_RDWR::(if create then [O_CREAT] else []) in
let d = openfile dbfile flags 0o666 in
lockf d F_LOCK 0;
d
(** Open DB file and lock. Optionally create if it does not exist. *)
let close_db (d:Unix.file_descr) =
let open Unix in
ignore (lseek d 0 SEEK_SET);
lockf d F_ULOCK 0
(** Unlock and close DB file. *)
let read_db (d:Unix.file_descr) : db =
let open Unix in
ignore (lseek d 0 SEEK_SET);
if (fstat d).st_size = 0 then StringMap.empty
else (
let f = in_channel_of_descr d in
let v : string = Marshal.from_channel f in
if v <> version then failwith ("Invalid DB format: reading version "^v^" but version "^version^" was expected");
Marshal.from_channel f
)
(** Read from open DB file. *)
let write_db (d:Unix.file_descr) (db:db) =
let open Unix in
ignore (lseek d 0 SEEK_SET);
ftruncate d 0;
let f = out_channel_of_descr d in
Marshal.to_channel f version [];
Marshal.to_channel f db [];
flush f
(** Write to open DB file. *)
let load_db (dbfile:string) : db =
let d = open_db dbfile in
let db = read_db d in
close_db d;
db
(** Load DB from file. *)
(** {1 DB extraction for analysis driver} *)
(** extract executables from DB *)
let get_executables (db:db) : string list =
let r =
StringMap.fold
(fun n (_,k) acc ->
match k with
| Executable _ -> n::acc
| _ -> acc
) db []
in
List.rev r
let get_libraries (db:db) : string list =
let r =
StringMap.fold
(fun n (_,k) acc ->
match k with
| Library _ -> n::acc
| _ -> acc
) db []
in
List.rev r
(** get all the sources making an executable (including library contents) *)
let get_file_sources ?(expected_kind = Executable []) (db:db) (exe:string) : source list =
let rec doit acc = function
| (_,Object src)::rest ->
doit (SourceSet.add src acc) rest
| (_,Library (_,m))::rest ->
doit (StringMap.fold (fun _ f acc -> doit acc [f]) m acc) rest
| (_,Unknown src)::rest ->
doit (SourceSet.add (source_unknown src) acc) rest
| _::rest ->
doit acc rest
| [] -> acc
in
match StringMap.find exe db, expected_kind with
| (_, Executable l), Executable _ -> SourceSet.elements (doit SourceSet.empty l)
| (_, Library (lk, contents)), Library _ -> SourceSet.elements (doit SourceSet.empty (List.map snd (StringMap.bindings contents)))
| _ -> raise Not_found
(** as get_executable_file_sources, but use the executable name instead of absolute file path *)
let get_executable_sources (db:db) (exe:string) : source list =
let exe = Filename.basename exe in
let m = StringMap.filter (fun k _ -> Filename.basename k = exe) db in
if StringMap.is_empty m then raise Not_found
else get_file_sources db (fst (StringMap.min_binding m))
let get_library_sources (db:db) (lib:string) : source list =
let lib = Filename.basename lib in
let m = StringMap.filter (fun k _ -> Filename.basename k = lib) db in
if StringMap.is_empty m then raise Not_found
else get_file_sources ~expected_kind:(Library (LIBRARY_DYNAMIC, StringMap.empty)) db (fst (StringMap.min_binding m))