Source file cudfAdd.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
module Pcre = Re_pcre
module OCAMLHashtbl = Hashtbl
open ExtLib
include Util.Logging (struct
let label = "dose_common.cudfAdd"
end)
let equal = Cudf.( =% )
let compare = Cudf.( <% )
let sort ?(asc = false) l =
let cmp = if asc then fun a b -> compare b a else compare in
List.sort ~cmp l
let hash p = Hashtbl.hash (p.Cudf.package, p.Cudf.version)
module Cudf_hashtbl = OCAMLHashtbl.Make (struct
type t = Cudf.package
let equal = equal
let hash = hash
end)
module Cudf_set = Set.Make (struct
type t = Cudf.package
let compare = compare
end)
let to_set l = List.fold_right Cudf_set.add l Cudf_set.empty
let is_nan_version = function
| 1073741822 -> true
| 1073741823 -> true
| i when Int32.to_int Int32.max_int > 0 && i = Int32.to_int Int32.max_int - 1
->
true
| i when Int32.to_int Int32.max_int > 0 && i = Int32.to_int Int32.max_int ->
true
| _ -> false
let nan_version = 1073741822
(** Encode - Decode *)
module EncodingHashtable = OCAMLHashtbl.Make (struct
type t = string
let equal = ( = )
let hash s = Char.code s.[0]
end)
module DecodingHashtable = OCAMLHashtbl.Make (struct
type t = string
let equal = ( = )
let hash s = (Char.code s.[1] * 1000) + Char.code s.[2]
end)
let init_hashtables enc_ht dec_ht =
let n = ref 255 in
while !n >= 0 do
let schr = String.make 1 (Char.chr !n) in
let hchr = Printf.sprintf "%%%02x" !n in
EncodingHashtable.add enc_ht schr hchr ;
DecodingHashtable.add dec_ht hchr schr ;
decr n
done
let enc_ht = EncodingHashtable.create 256
let dec_ht = DecodingHashtable.create 256;;
init_hashtables enc_ht dec_ht
let encode_single s = EncodingHashtable.find enc_ht s
let not_allowed_regexp = Pcre.regexp "[^a-zA-Z0-9@/+().-]"
let encode s = Pcre.substitute ~rex:not_allowed_regexp ~subst:encode_single s
let decode_single s = DecodingHashtable.find dec_ht s
let encoded_char_regexp = Pcre.regexp "%[0-9a-f][0-9a-f]"
let decode s = Pcre.substitute ~rex:encoded_char_regexp ~subst:decode_single s
(** Pretty Printing *)
let string_of pp arg =
ignore (pp Format.str_formatter arg) ;
Format.flush_str_formatter ()
let pp_version fmt pkg =
try
Format.fprintf fmt "%s" (decode (Cudf.lookup_package_property pkg "number"))
with Not_found -> Format.fprintf fmt "%d" pkg.Cudf.version
let pp_package fmt pkg =
Format.fprintf fmt "%s (= %a)" (decode pkg.Cudf.package) pp_version pkg
let string_of_version = string_of pp_version
let string_of_package = string_of pp_package
type pp =
Cudf.package ->
string * string option * string * (string * (string * bool)) list
(** [default_pp] default package printer. If the version of the package is
* a negative number, the version version if printed as "nan" *)
let default_pp pkg =
let v = if pkg.Cudf.version > 0 then string_of_version pkg else "nan" in
(pkg.Cudf.package, None, v, [])
let pp from_cudf ?(fields = []) ?(decode = decode) pkg =
let (p, a, v) = from_cudf (pkg.Cudf.package, pkg.Cudf.version) in
let default_fields =
["architecture"; "source"; "sourcenumber"; "essential"; "type"]
in
let f b l acc =
List.fold_left
(fun acc k ->
try (k, (decode (Cudf.lookup_package_property pkg k), b)) :: acc
with Not_found -> acc)
acc
l
in
let l = f false fields (f true default_fields []) in
(p, a, v, l)
let pp_vpkg pp fmt vpkg =
let string_of_relop = function
| `Eq -> "="
| `Neq -> "!="
| `Geq -> ">="
| `Gt -> ">"
| `Leq -> "<="
| `Lt -> "<"
in
let dummy p v = { Cudf.default_package with Cudf.package = p; version = v } in
match vpkg with
| (p, None) -> (
match pp (dummy p nan_version) with
| (p, None, _, _) -> Format.fprintf fmt "%s" p
| (p, Some a, _, _) -> Format.fprintf fmt "%s:%s" p a)
| (p, Some (c, v)) -> (
match pp (dummy p v) with
| (p, None, ("nan" | ""), _) -> Format.fprintf fmt "%s" p
| (p, None, v, _) ->
Format.fprintf fmt "%s (%s %s)" p (string_of_relop c) v
| (p, Some a, ("nan" | ""), _) -> Format.fprintf fmt "%s:%s" p a
| (p, Some a, v, _) ->
Format.fprintf fmt "%s:%s (%s %s)" p a (string_of_relop c) v)
let pp_vpkglist pp fmt =
let pp_list fmt ~pp_item ~sep l =
let rec aux fmt = function
| [] -> assert false
| [last] ->
Format.fprintf fmt "@,%a" pp_item last
| vpkg :: tl ->
Format.fprintf fmt "@,%a%s" pp_item vpkg sep ;
aux fmt tl
in
match l with
| [] -> ()
| [sole] -> pp_item fmt sole
| _ -> Format.fprintf fmt "@[<h>%a@]" aux l
in
pp_list fmt ~pp_item:(pp_vpkg pp) ~sep:" | "
module StringSet = Set.Make (String)
let add_to_package_list h n p =
try
let l = Hashtbl.find h n in
l := p :: !l
with Not_found -> Hashtbl.add h n (ref [p])
let get_package_list h n = try !(Hashtbl.find h n) with Not_found -> []
let pkgnames universe =
Cudf.fold_packages
(fun names pkg -> StringSet.add pkg.Cudf.package names)
StringSet.empty
universe
let add_properties preamble l =
List.fold_left
(fun pre prop -> { pre with Cudf.property = prop :: pre.Cudf.property })
preamble
l
let get_property prop pkg =
try Cudf.lookup_package_property pkg prop
with Not_found ->
warning "%s missing" prop ;
raise Not_found
let is_essential pkg =
try Cudf.lookup_package_property pkg "essential" = "true"
with Not_found -> false
let realversionmap pkglist =
let h = Hashtbl.create (5 * List.length pkglist) in
List.iter
(fun pkg -> Hashtbl.add h (pkg.Cudf.package, string_of_version pkg) pkg)
pkglist ;
h
let pkgtoint universe p =
try Cudf.uid_by_package universe p
with Not_found ->
warning
"package %s is not associate with an integer in the given universe"
(string_of_package p) ;
raise Not_found
let inttopkg = Cudf.package_by_uid
let normalize_set (l : int list) =
List.rev
(List.fold_left
(fun results x -> if List.mem x results then results else x :: results)
[]
l)
let who_provides univ (pkgname, constr) =
let pkgl = Cudf.lookup_packages ~filter:constr univ pkgname in
let prol = Cudf.who_provides ~installed:false univ (pkgname, constr) in
let filter = function
| (p, None) -> Some p
| (p, Some v) when Cudf.version_matches v constr -> Some p
| _ -> None
in
pkgl @ List.filter_map filter prol
let resolve_vpkg_int univ vpkg =
List.map (Cudf.uid_by_package univ) (who_provides univ vpkg)
let resolve_vpkgs_int univ vpkgs =
normalize_set (List.flatten (List.map (resolve_vpkg_int univ) vpkgs))
let resolve_deps univ vpkgs =
List.map (Cudf.package_by_uid univ) (resolve_vpkgs_int univ vpkgs)
let who_depends univ pkg = List.map (resolve_deps univ) pkg.Cudf.depends
type ctable = (int, int list ref) ExtLib.Hashtbl.t
let who_conflicts conflicts_packages univ pkg =
if Hashtbl.length conflicts_packages = 0 then
debug
"Either there are no conflicting packages in the universe or you\n\
CudfAdd.init_conflicts was not invoked before calling \
CudfAdd.who_conflicts" ;
let i = Cudf.uid_by_package univ pkg in
List.map (Cudf.package_by_uid univ) (get_package_list conflicts_packages i)
let init_conflicts univ =
let conflict_pairs = Hashtbl.create 1023 in
let conflicts_packages = Hashtbl.create 1023 in
Cudf.iteri_packages
(fun i p ->
List.iter
(fun n ->
let pair = (min n i, max n i) in
if n <> i && not (Hashtbl.mem conflict_pairs pair) then (
Hashtbl.add conflict_pairs pair () ;
add_to_package_list conflicts_packages i n ;
add_to_package_list conflicts_packages n i))
(resolve_vpkgs_int univ p.Cudf.conflicts))
univ ;
conflicts_packages
let compute_pool universe =
let size = Cudf.universe_size universe in
let conflicts = init_conflicts universe in
let c = Array.init size (fun i -> get_package_list conflicts i) in
let d =
Array.init size (fun i ->
let p = Cudf.package_by_uid universe i in
List.map (resolve_vpkgs_int universe) p.Cudf.depends)
in
(d, c)
let latest ?(n = 1) pkglist =
let h = Hashtbl.create (List.length pkglist) in
List.iter (fun p -> add_to_package_list h p.Cudf.package p) pkglist ;
Hashtbl.fold
(fun _ { contents = l } acc ->
if List.length l <= n then l @ acc
else fst (List.split_nth n (sort ~asc:true l)) @ acc)
h
[]
let cone universe pkgs =
let l = ref [] in
let queue = Queue.create () in
let visited = Hashtbl.create (2 * List.length pkgs) in
List.iter (fun pkg -> Queue.add (Cudf.uid_by_package universe pkg) queue) pkgs ;
while Queue.length queue > 0 do
let id = Queue.take queue in
let pkg = Cudf.package_by_uid universe id in
if not (Hashtbl.mem visited id) then (
l := pkg :: !l ;
Hashtbl.add visited id () ;
List.iter
(fun vpkgs ->
match resolve_vpkgs_int universe vpkgs with
| [i] when not (Hashtbl.mem visited i) -> Queue.add i queue
| dsj ->
List.iter
(fun i -> if not (Hashtbl.mem visited i) then Queue.add i queue)
dsj)
pkg.Cudf.depends)
done ;
!l