File: buildcheck-more-problems.ml

package info (click to toggle)
botch 0.21-8
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 1,298,428 kB
  • sloc: xml: 11,924,948; ml: 4,497; python: 3,620; sh: 1,269; makefile: 319
file content (267 lines) | stat: -rw-r--r-- 10,554 bytes parent folder | download | duplicates (3)
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
(**************************************************************************************)
(*  Copyright (C) 2009 Pietro Abate <pietro.abate@pps.jussieu.fr>                     *)
(*  Copyright (C) 2009 Mancoosi Project                                               *)
(*  Copyright (C) 2014 Johannes Schauer <j.schauer@email.de>                          *)
(*                                                                                    *)
(*  This library is free software: you can redistribute it and/or modify              *)
(*  it under the terms of the GNU Lesser General Public License as                    *)
(*  published by the Free Software Foundation, either version 3 of the                *)
(*  License, or (at your option) any later version.  A special linking                *)
(*  exception to the GNU Lesser General Public License applies to this                *)
(*  library, see the COPYING file for more information.                               *)
(**************************************************************************************)

open! ExtLib
open Debian
open Common
open Algo
open DoseparseNoRpm

module Src = Debian.Sources
module Deb = Debian.Packages

module Options = struct
  open OptParse
  let description =
    "Report the broken packages in a debian source list. \
     You must provide a (list of) Debian Packages file(s) and \
     a Debian Sources file in this order"
  let options = OptParser.make ~description
  include StdOptions.MakeOptions(struct let options = options end)

  let dump = StdOpt.str_option ()
  let maforeign = StdOpt.store_true ()
  let includextra = StdOpt.store_true ()
  let tupletable = StdOpt.str_option ()
  let cputable = StdOpt.str_option ()
  let dropalternatives = StdOpt.store_true ()

  include StdOptions.DistcheckOptions ;;
  StdOptions.DistcheckOptions.add_options options ;;

  include StdOptions.InputOptions ;;
  let default = 
    List.fold_left (fun acc e ->
      List.remove acc e
    ) StdOptions.InputOptions.default_options ["inputtype";"fg";"bg";"compare"]
  in
  StdOptions.InputOptions.add_options ~default options ;

  include StdOptions.OutputOptions ;;
  StdOptions.OutputOptions.add_options options ;;
  StdOptions.OutputOptions.add_option options ~long_name:"dump" ~help:"dump the cudf file" dump;

  include StdOptions.DistribOptions ;;
  StdOptions.DistribOptions.add_debian_options options ;;
  let group = StdOptions.DistribOptions.deb_group options in
  StdOptions.DistribOptions.add_option options ~group ~long_name:"deb-tupletable"
    ~help:"Path to an architecture tuple table like /usr/share/dpkg/tupletable" tupletable;
  StdOptions.DistribOptions.add_option options ~group ~long_name:"deb-cputable"
    ~help:"Path to a cpu table like /usr/share/dpkg/cputable" cputable;
  StdOptions.DistribOptions.add_option options ~group ~long_name:"deb-defaulted-m-a-foreign"
    ~help:"Convert Arch:all packages to Multi-Arch: foreign" maforeign;
  StdOptions.DistribOptions.add_option options ~group ~long_name:"deb-include-extra-source"
    ~help:"Include packages with Extra-Source-Only:yes (dropped by default)" includextra;
  StdOptions.DistribOptions.add_option options ~group ~long_name:"deb-emulate-sbuild"
    ~help:"replicate sbuild behaviour to only keep the first alternative of build dependencies" dropalternatives;

end

#define __label __FILE__
let label =  __label ;;
include Util.Logging(struct let label = label end) ;;

let timer = Util.Timer.create "Solver"
let progress = Util.Progress.create "Solver"

let main () =
  let posargs = OptParse.OptParser.parse_argv Options.options in
  StdDebug.enable_debug (OptParse.Opt.get Options.verbose);
  StdDebug.enable_timers (OptParse.Opt.get Options.timers) ["Solver";"Load.DebianSource"];
  StdDebug.enable_bars (OptParse.Opt.get Options.progress) ["Solver"];
  Util.Debug.disable "Depsolver_int";
  StdDebug.all_quiet (OptParse.Opt.get Options.quiet);

  if not(OptParse.Opt.is_set Options.deb_native_arch) then
    fatal "You must at least specify the native architecture";

  let fmt =
    if OptParse.Opt.is_set Options.outfile then
      let oc = open_out (OptParse.Opt.get Options.outfile) in
      Format.formatter_of_out_channel oc
    else
      Format.std_formatter
  in
  (* we set the Debian.Debcudf options wrt the user provided options *)
  let options = Options.set_deb_options () in
  (* buildarch and native arch must be set to some architecture at this point *)
  let buildarch = Option.get options.Debian.Debcudf.native in
  (* hostarch can be None *)
  let hostarch = match options.Debian.Debcudf.host with None -> "" | Some s -> s in
  let noindep = options.Debian.Debcudf.drop_bd_indep in
  let dropalternatives = OptParse.Opt.get Options.dropalternatives in
  let profiles = options.Debian.Debcudf.profiles in

  let filter_external_sources par =
    if (OptParse.Opt.get Options.includextra) then true
    else
      try not(Pef.Packages.parse_bool
        ("extra-source-only",(Pef.Packages.assoc "extra-source-only" par)))
      with Not_found -> true
  in

  if (OptParse.Opt.is_set Options.tupletable)
  || OptParse.Opt.is_set Options.cputable then begin
    let ttfile = if OptParse.Opt.is_set Options.tupletable then
        Some (OptParse.Opt.get Options.tupletable)
      else None in
    let ctfile = if OptParse.Opt.is_set Options.cputable then
        Some (OptParse.Opt.get Options.cputable)
      else None in
    Architecture.read_tupletable ~ttfile ~ctfile ()
  end;

  let pkglist, srclist =
    match posargs with
    |[] | [_] -> fatal 
      "You must provide a list of Debian Packages files and \
       a Debian Sources file"
    |l -> 
        begin match List.rev l with
        |h::t ->
          let srclist =
            StdLoaders.deb_load_source 
              ~dropalternatives 
              ~profiles 
              ~filter:filter_external_sources 
              ~noindep buildarch hostarch h 
          in
          let pkglist = Deb.input_raw t in
          (pkglist,srclist)
        |_ -> fatal "An impossible situation occurred ?!#"
        end
  in
  let tables = Debcudf.init_tables (srclist @ pkglist) in
  let global_constraints = Debian.Debcudf.get_essential ~options tables in
  let to_cudf (p,v) = (p,Debian.Debcudf.get_cudf_version tables (p,v)) in
  let from_cudf (p,v) = Debian.Debcudf.get_real_version tables (p,v) in
  let pp = CudfAdd.pp ?fields:None ?decode:None from_cudf in 

  (* XXX here latest could be a bit faster if done at the same time of the cudf
     conversion *)
  let sl = 
    let l = List.map (fun pkg -> Debcudf.tocudf ~options tables pkg) srclist in
    if OptParse.Opt.is_set Options.latest then
      CudfAdd.latest ~n:(OptParse.Opt.get Options.latest) l
    else
      l
  in
  let bl = 
    List.fold_left (fun acc pkg ->
      let pkg = 
        if OptParse.Opt.get Options.maforeign && pkg#architecture = "all" then
          pkg#set_multiarch `Foreign
        else pkg
      in
      (Debcudf.tocudf ~options tables pkg)::acc
    ) sl pkglist 
  in

  let universe = ref (Cudf.load_universe bl) in
  let universe_size = Cudf.universe_size !universe in

  let failure = OptParse.Opt.get Options.failure in
  let success = OptParse.Opt.get Options.success in
  let explain =
    if success || failure then
      OptParse.Opt.get Options.explain
    else false
  in
  let minimal = OptParse.Opt.get Options.minimal in
  let summary = OptParse.Opt.get Options.summary in

  let checklist =
    if OptParse.Opt.is_set Options.checkonly then begin
      List.flatten (
        List.map (fun ((n,a),c) ->
          let (name,filter) = Pef.Pefcudf.pefvpkg to_cudf (("src:"^n,a),c) in
          Cudf.lookup_packages ~filter !universe name
        ) (OptParse.Opt.get Options.checkonly)
      )
    end else sl
  in

  Diagnostic.pp_out_version fmt;

  if OptParse.Opt.is_set Options.deb_native_arch then
    Format.fprintf fmt "native-architecture: %s@."
      (OptParse.Opt.get Options.deb_native_arch);

  if OptParse.Opt.is_set Options.deb_foreign_archs then
    Format.fprintf fmt "foreign-architecture: %s@."
      (String.concat "," (OptParse.Opt.get Options.deb_foreign_archs));

  if OptParse.Opt.is_set Options.deb_host_arch then
    Format.fprintf fmt "host-architecture: %s@."
      (OptParse.Opt.get Options.deb_host_arch);

  let results = Diagnostic.default_result universe_size in

  if failure || success then Format.fprintf fmt "@[<v 1>report:@,";
  let failures = ref [] in
  let callback = function
    | {Diagnostic.result = Diagnostic.Failure _ ; request = [r]} -> failures := r::!failures
    | {Diagnostic.result = Diagnostic.Success _ } as d ->
      Diagnostic.fprintf ~pp ~failure ~success ~explain ~minimal fmt d
    | _ -> failwith "impossible"
  in

  Util.Timer.start timer;
  let nbp = Depsolver.listcheck ~global_constraints ~callback ~explain !universe checklist in

  Util.Progress.set_total progress (List.length !failures);
  (* process the packages to check one by one because the changes to the
   * universe made for one package must not propagate to the others *)
  List.iter (fun pkg ->
      Util.Progress.progress progress;
      info "working on %s" (BootstrapCommon.string_of_package pkg);
      (* reset the universe to its original state before every run *)
      universe := Cudf.load_universe bl;
      let rec aux () =
        match Depsolver.listcheck ~global_constraints ~callback:(BootstrapCommon.more_problems_callback (Diagnostic.fprintf ~pp ~failure ~success ~explain ~minimal fmt) universe results summary) !universe [pkg] with
        | 0 -> ()
        | _ -> aux ()
      in
      aux ();
    ) (BootstrapCommon.debcudf_sort !failures);
  ignore(Util.Timer.stop timer ());

  (* reset the universe to its original state after the last run *)
  universe := Cudf.load_universe bl;

  if failure || success then Format.fprintf fmt "@]@.";

  let nb = universe_size in
  let nf = List.length sl in
  Format.fprintf fmt "binary-packages: %d@." nb;
  Format.fprintf fmt "source-packages: %d@." (if nf = 0 then nb else nf);
  Format.fprintf fmt "broken-packages: %d@." nbp;

  if summary then
    Format.fprintf fmt "@[%a@]@." (Diagnostic.pp_summary ~pp ()) results;

  if OptParse.Opt.is_set Options.dump then begin
    let oc = open_out (OptParse.Opt.get Options.dump) in
    info "Dumping Cudf file";
    
    Cudf_printer.pp_preamble oc Debcudf.preamble;
    Printf.fprintf oc "\n";
    Cudf_printer.pp_universe oc !universe
  end;
  nbp
;;

StdUtils.if_application
  ~alternatives:["botch-buildcheck-more-problems"]
  __label main
;;