package dose3-extra

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file stdOptions.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
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
(**************************************************************************)
(*  This file is part of a library developed with the support of the      *)
(*  Mancoosi Project. http://www.mancoosi.org                             *)
(*                                                                        *)
(*  Main author(s):  Pietro Abate                                         *)
(*                                                                        *)
(*  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 Dose_common
open Dose_extra

include Util.Logging (struct
  let label = "doseparse.stdOptions"
end)

module type Ot = sig
  val options :
    ?usage:string ->
    ?status:int ->
    ?version:string ->
    ?suppress_usage:bool ->
    ?suppress_help:bool ->
    ?prog:string ->
    ?formatter:OptParse.Formatter.t ->
    unit ->
    OptParse.OptParser.t
end

(* *************************************** *)

let vpkg_option ?default ?(metavar = " <vpkg>") () =
  let parse_vpkg s =
    let _loc = Format822.dummy_loc in
    Dose_pef.Packages.parse_vpkg ("cmdline <vpkg>", (_loc, s))
  in
  OptParse.Opt.value_option metavar default parse_vpkg (fun _ s ->
      Printf.sprintf "Invalid vpackage '%s'" s)

(* this is a ,-separated list of vpkgs of the form "a (<c> v)" *)
let vpkglist_option ?default ?(metavar = " <vpkglst>") () =
  let parse_vpkglist s =
    let _loc = Format822.dummy_loc in
    Dose_pef.Packages.parse_vpkglist ("cmdline <vpkglst>", (_loc, s))
  in
  OptParse.Opt.value_option metavar default parse_vpkglist (fun _ s ->
      Printf.sprintf "Invalid vpackage list '%s'" s)

(* this is a ,-separated list of vpkgs of the form "a (= v)" *)
let pkglist_option ?default ?(metavar = " <pkglst>") () =
  let parse_vpkglist s =
    let _loc = Format822.dummy_loc in
    List.map
      (function
        | ((n, a), Some ("=", v)) -> (n, a, v)
        | ((_, _), None) ->
            raise (Format822.ParseError ([], s, "you must specify a version"))
        | _ -> raise (Format822.ParseError ([], s, "")))
      (Dose_pef.Packages.parse_vpkglist ("cmdline <pkglst>", (_loc, s)))
  in
  OptParse.Opt.value_option metavar default parse_vpkglist (fun _ s ->
      Printf.sprintf "Invalid package list '%s'" s)

(* this is a ,-separated list of optimization criteria *)
let criteria_option ?default ?(metavar = " <criteria>") () =
  let parse_criteria s =
    let _loc = Format822.dummy_loc in
    Criteria.parse_criteria ("cmdline <criteria>", (_loc, s))
  in
  OptParse.Opt.value_option metavar default parse_criteria (fun _ s ->
      Printf.sprintf "Invalid criteria list '%s'" s)

(* *************************************** *)

let incr_str_list ?(default = Some []) ?(metavar = " <str>") =
  let acc = ref [] in
  let coerce s =
    acc := s :: !acc ;
    !acc
  in
  fun () ->
    OptParse.Opt.value_option metavar default coerce (fun _ s ->
        Printf.sprintf "Invalid String '%s'" s)

(* this is a ,-separated list of strings *)
let str_list_option ?default ?(metavar = " <strlst>") =
  let sep = "," in
  let coerce s = ExtString.String.nsplit s sep in
  fun () ->
    OptParse.Opt.value_option metavar default coerce (fun _ s ->
        Printf.sprintf "Invalid String '%s'" s)

(* *************************************** *)

module MakeOptions (O : Ot) = struct
  open OptParse

  let verbose = StdOpt.incr_option ()

  let quiet = StdOpt.store_true ()

  let progress = StdOpt.store_true ()

  let timers = StdOpt.store_true ()

  let version =
    let abbreviated_commit_hash =
      if String.length GitVersionInfo.commit_hash >= 8 then
        String.sub GitVersionInfo.commit_hash 0 8
      else GitVersionInfo.commit_hash
    in

    Format.asprintf
      "%s %s %s"
      VersionInfo.version
      abbreviated_commit_hash
      GitVersionInfo.committer_date

  let options = O.options ~status:64 ~version ()

  open OptParser;;

  add
    options
    ~short_name:'v'
    ~long_name:"verbose"
    ~help:"print additional information"
    verbose ;
  add options ~long_name:"progress" ~help:"print progress bars" progress ;
  add options ~long_name:"timers" ~help:"print timing information" timers ;
  add options ~long_name:"quiet" ~help:"do no print any messages" quiet
end

let create_group group descr options =
  if not (Option.is_none !group) then Option.get !group
  else
    let g = OptParse.OptParser.add_group options descr in
    let _ = group := Some g in
    g

module DistcheckOptions = struct
  open OptParse

  let success = StdOpt.store_true ()

  let failure = StdOpt.store_true ()

  let explain = StdOpt.store_true ()

  let minimal = StdOpt.store_true ()

  let condense = StdOpt.store_true ()

  let summary = StdOpt.store_true ()

  let default_options =
    [ "success";
      "failure";
      "explain";
      "explain-minimal";
      "explain-condense";
      "summary" ]

  let group = ref None

  let descr = "Distcheck Options"

  let add_options ?(default = default_options) options =
    let open OptParser in
    if List.length default > 0 then (
      let group = create_group group descr options in
      if List.mem "explain" default then
        add
          options
          ~group
          ~short_name:'e'
          ~long_name:"explain"
          ~help:"Explain the results"
          explain ;
      if List.mem "explain-minimal" default then
        add
          options
          ~group
          ~short_name:'m'
          ~long_name:"explain-minimal"
          ~help:"Do not print dependency chains of results"
          minimal ;
      if List.mem "explain-condense" default then
        add
          options
          ~group
          ~short_name:'c'
          ~long_name:"explain-condense"
          ~help:"Compress explanation graph"
          condense ;
      if List.mem "failure" default then
        add
          options
          ~group
          ~short_name:'f'
          ~long_name:"failures"
          ~help:"Only show failures"
          failure ;
      if List.mem "success" default then
        add
          options
          ~group
          ~short_name:'s'
          ~long_name:"successes"
          ~help:"Only show successes"
          success ;
      if List.mem "summary" default then
        add
          options
          ~group
          ~long_name:"summary"
          ~help:"Show Failures Summary"
          summary)

  let add_option ?short_name ?long_name ?help options =
    let open OptParser in
    let group = create_group group descr options in
    add options ~group ?short_name ?long_name ?help
end

module OutputOptions = struct
  open OptParse

  let outfile = StdOpt.str_option ()

  let outdir = StdOpt.str_option ()

  let dot = StdOpt.store_true ()

  let default_options = ["outfile"; "outdir"; "dot"]

  let group = ref None

  let descr = "Output Options"

  let add_options ?(default = default_options) options =
    let open OptParser in
    if List.length default > 0 then (
      let group = create_group group descr options in
      if List.mem "outfile" default then
        add
          options
          ~group
          ~short_name:'o'
          ~long_name:"outfile"
          ~help:"Redirect the output to a file (default stdout)"
          outfile ;
      if List.mem "outdir" default then
        add
          options
          ~group
          ~short_name:'d'
          ~long_name:"outdir"
          ~help:"Set the output directory (default current directory)"
          outdir ;
      if List.mem "dot" default then
        add
          options
          ~group
          ~long_name:"dot"
          ~help:
            "Save the explanation graph (one for each package) in dot format"
          dot)

  let add_option ?short_name ?long_name ?help options =
    let open OptParser in
    let group = create_group group descr options in
    add options ~group ?short_name ?long_name ?help
end

module InputOptions = struct
  open OptParse

  let itypes = List.map Url.scheme_to_string Url.supported_input_types

  let in_option ?default
      ?(metavar = Printf.sprintf "<%s>" (String.concat "|" itypes)) () =
    let coerce s = if List.mem s itypes then s else raise Not_found in
    let supported = String.concat ", " itypes in
    let error _ s =
      Printf.sprintf
        "input format \"%s\" not supported. Must be one of: %s"
        s
        supported
    in
    Opt.value_option metavar default coerce error

  let vtypes = Dose_versioning.Utils.supported_formats

  let comp_option ?default
      ?(metavar = Printf.sprintf "<%s>" (String.concat "|" vtypes)) () =
    let coerce s = if List.mem s vtypes then s else raise Not_found in
    let supported = String.concat ", " vtypes in
    let error _ s =
      Printf.sprintf
        "comparison function \"%s\" not supported. Must be one of: %s"
        s
        supported
    in
    Opt.value_option metavar default coerce error

  let trim = StdOpt.store_true ()

  let latest = StdOpt.int_option ()

  let checkonly = StdDebian.vpkglist_option ()

  let background = incr_str_list ()

  let foreground = incr_str_list ()

  let inputtype = in_option ()

  let compare = comp_option ()

  let default_options =
    [(* "trim"; *) "inputtype"; "latest"; "checkonly"; "bg"; "fg"; "compare"]

  let group = ref None

  let descr = "Input Options"

  (** give a list of positional arguments returns two list of resources,
      foreground and background. Positional arguments are assumed to be
      foreground resources. *)
  let parse_cmdline (it, im) posargs =
    let add_format t = List.map (fun s -> Url.scheme_to_string t ^ "://" ^ s) in
    let fg = OptParse.Opt.get foreground in
    let bg = OptParse.Opt.get background in
    let fg = (if List.length (posargs @ fg) = 0 then ["-"] else posargs) @ fg in
    if im then (add_format it fg, add_format it bg) else (fg, bg)

  let add_options ?(default = default_options) options =
    let open OptParser in
    if List.length default > 0 then (
      let group = create_group group descr options in
      if List.mem "inputtype" default then
        add
          options
          ~group
          ~short_name:'t'
          ~help:"Set the input type format"
          inputtype ;
      if List.mem "checkonly" default then
        add
          options
          ~group
          ~long_name:"checkonly"
          ~help:"Check only these packages"
          checkonly ;
      if List.mem "trim" default then
        add
          options
          ~group
          ~long_name:"trim"
          ~help:"Consider only installable packages"
          trim ;
      if List.mem "latest" default then
        add
          options
          ~group
          ~long_name:"latest"
          ~help:"Consider only the latest N versions of each package"
          latest ;
      if List.mem "fg" default then
        add
          options
          ~group
          ~long_name:"fg"
          ~help:
            ("Additional Packages lists that are checked and used "
           ^ "for resolving dependencies (can be repeated)")
          foreground ;
      if List.mem "bg" default then
        add
          options
          ~group
          ~long_name:"bg"
          ~help:
            ("Additional Packages lists that are NOT checked but used "
           ^ "for resolving dependencies (can be repeated)")
          background ;
      if List.mem "compare" default then
        add
          options
          ~group
          ~long_name:"compare"
          ~help:"When used with a pef input type, selects a comparison function"
          compare)

  let add_option ?short_name ?long_name ?help options =
    let open OptParser in
    let group = create_group group descr options in
    add options ~group ?short_name ?long_name ?help
end

type options =
  | Deb of Dose_debian.Debcudf.options
  | Pef of Dose_debian.Debcudf.options
  | Opam of Dose_opam2.Opamcudf.options
  | Edsp of Dose_debian.Debcudf.options
  | Csw
  | Rpm
  | Cudf

module DistribOptions = struct
  open OptParse

  let deb_native_arch = StdOpt.str_option ()

  let deb_foreign_archs = str_list_option ()

  let deb_host_arch = StdOpt.str_option ()

  let deb_ignore_essential = StdOpt.store_true ()

  let deb_builds_from = StdOpt.store_true ()

  let deb_drop_bd_indep = StdOpt.store_true ()

  let deb_drop_bd_arch = StdOpt.store_true ()

  let deb_profiles = str_list_option ()

  let opam_switch = StdOpt.str_option ~default:"system" ()

  let opam_switches = str_list_option ()

  let opam_profiles = str_list_option ()

  let default_options =
    [ "deb-native-arch";
      "deb-host-arch";
      "deb-foreign-archs";
      "deb-ignore-essential";
      "deb-builds-from";
      "deb-drop-b-d-indep";
      "deb-drop-b-d-arch";
      "deb-profiles";
      "opam-switch";
      "opam-switches";
      "opam-profiles" ]

  let set_deb_options () =
    let native = Opt.opt deb_native_arch in
    let host =
      if Opt.is_set deb_host_arch then (
        (* if host arch is set, native arch must be set *)
        if Option.is_none native then
          fatal "you must specify at least the native architecture" ;
        Opt.opt deb_host_arch)
      else native
    in
    let foreign =
      (* if host arch is set, it is an implicit foreign arch *)
      if Opt.is_set deb_foreign_archs then
        let f = Opt.get deb_foreign_archs in
        (* make the list unique *)
        let f = List.unique f in
        (* remove native arch and host arch from the list or otherwise we could
         * have the situation where the native arch also appears as a foreign
         * arch or where the host arch appears twice *)
        let f = List.filter (fun e -> Some e <> host && Some e <> native) f in
        if Opt.is_set deb_host_arch then Option.get host :: f else f
      else if Opt.is_set deb_host_arch then [Option.get host]
      else []
    in
    let profiles =
      if Opt.is_set deb_profiles then Opt.get deb_profiles
      else
        try String.nsplit (Sys.getenv "DEB_BUILD_PROFILES") " "
        with Not_found -> []
    in
    { Dose_debian.Debcudf.default_options with
      Dose_debian.Debcudf.native;
      foreign;
      host;
      ignore_essential = Opt.get deb_ignore_essential;
      builds_from = Opt.get deb_builds_from;
      drop_bd_indep = Opt.get deb_drop_bd_indep;
      drop_bd_arch = Opt.get deb_drop_bd_arch;
      profiles
    }

  let set_opam_options () =
    let switch = Opt.get opam_switch in
    let switches =
      if Opt.is_set opam_switches then Opt.get opam_switches else []
    in
    let profiles =
      if Opt.is_set opam_profiles then Opt.get opam_profiles else []
    in
    { Dose_opam2.Opamcudf.default_options with
      Dose_opam2.Opamcudf.switch;
      switches;
      profiles
    }

  let set_default_options = function
    | `Deb ->
        Some
          (Deb
             { Dose_debian.Debcudf.default_options with
               Dose_debian.Debcudf.ignore_essential = true
             })
    | `Edsp ->
        Some
          (Edsp
             { Dose_debian.Debcudf.default_options with
               Dose_debian.Debcudf.ignore_essential = true
             })
    | `Pef -> Some (Pef Dose_debian.Debcudf.default_options)
    | `Opam -> Some (Opam Dose_opam2.Opamcudf.default_options)
    | _ -> None

  let set_options = function
    | `Deb | `DebSrc -> Some (Deb (set_deb_options ()))
    | `Edsp -> Some (Edsp (set_deb_options ()))
    | `Pef -> Some (Pef Dose_debian.Debcudf.default_options)
    | `Opam -> Some (Opam (set_opam_options ()))
    | _ -> None

  let deb_group =
    let g = ref None in
    fun options ->
      match !g with
      | Some group -> group
      | None ->
          let group = OptParser.add_group options "Debian Specific Options" in
          g := Some group ;
          group

  let opam_group =
    let g = ref None in
    fun options ->
      match !g with
      | Some group -> group
      | None ->
          let group = OptParser.add_group options "Opam Specific Options" in
          g := Some group ;
          group

  let add_debian_options ?(default = default_options) options =
    let open OptParser in
    if List.length default > 0 then (
      let group = deb_group options in
      if List.mem "deb-native-arch" default then
        add
          options
          ~group
          ~long_name:"deb-native-arch"
          ~help:"Native architecture"
          deb_native_arch ;
      if List.mem "deb-host-arch" default then
        add
          options
          ~group
          ~long_name:"deb-host-arch"
          ~help:
            "Native/cross compile host architecture, defaults to native \
             architecture"
          deb_host_arch ;
      if List.mem "deb-foreign-archs" default then
        add
          options
          ~group
          ~long_name:"deb-foreign-archs"
          ~help:
            "Foreign architectures in addition to native and host architectures"
          deb_foreign_archs ;
      if List.mem "deb-ignore-essential" default then
        add
          options
          ~group
          ~long_name:"deb-ignore-essential"
          ~help:"Ignore Essential Packages"
          deb_ignore_essential ;
      if List.mem "deb-builds-from" default then
        add
          options
          ~group
          ~long_name:"deb-builds-from"
          ~help:
            "Add builds-from relationship of binary packages on source \
             packages as dependency"
          deb_builds_from ;
      if List.mem "deb-drop-b-d-indep" default then
        add
          options
          ~group
          ~long_name:"deb-drop-b-d-indep"
          ~help:
            "Drop the Build-Depends-Indep field from source packages (build no \
             Architecture:all packages)"
          deb_drop_bd_indep ;
      if List.mem "deb-drop-b-d-arch" default then
        add
          options
          ~group
          ~long_name:"deb-drop-b-d-arch"
          ~help:
            "Drop the Build-Depends-Arch field from source packages (build no \
             Architecture:any packages)"
          deb_drop_bd_arch ;
      if List.mem "deb-profiles" default then
        add
          options
          ~group
          ~long_name:"deb-profiles"
          ~help:"comma separated list of activated build profiles"
          deb_profiles)

  let add_opam_options ?(default = default_options) options =
    let open OptParser in
    if List.length default > 0 then (
      let group = opam_group options in
      if List.mem "opam-switch" default then
        add
          options
          ~group
          ~long_name:"opam-switch"
          ~help:"Active Switch"
          opam_switch ;
      if List.mem "opam-switches" default then
        add
          options
          ~group
          ~long_name:"opam-switches"
          ~help:"Available Switches"
          opam_switches ;
      if List.mem "opam-profiles" default then
        add
          options
          ~group
          ~long_name:"opam-profiles"
          ~help:"Build Profiles"
          opam_profiles)

  let add_option ?group ?short_name ?long_name ?help options v =
    let open OptParser in
    match group with
    | None -> add options ?short_name ?long_name ?help v
    | Some group -> add options ~group ?short_name ?long_name ?help v
end
OCaml

Innovation. Community. Security.