Source file posix_getopt.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
open Ctypes
include Posix_getopt_stubs.Def (Posix_getopt_generated_stubs)

type short = char
type long = string * char

type arg =
  [ `None of unit -> unit
  | `Optional of string option -> unit
  | `Required of string -> unit ]

type 'a opt = { name : 'a; arg : arg }

exception Unknown_option of string
exception Missing_argument of char

let () =
  Printexc.register_printer (function
    | Unknown_option s -> Some (Printf.sprintf "Unknown getopt option: %s" s)
    | Missing_argument c ->
        Some (Printf.sprintf "Missing argument for getopt option: %c" c)
    | _ -> None)

let opterr = getopterr ()
let optopt = getoptopt ()
let optind = getoptind ()
let optreset = getoptreset ()

let optarg () =
  let p = getoptarg () in
  string_from_ptr p ~length:(strlen p)

let print_error flag = opterr <-@ if flag then 1 else 0
let () = print_error false

let reset () =
  (* GNU *)
  if is_null optreset then optind <-@ 0
  else begin
    (* Others *)
    optreset <-@ 1;
    optind <-@ 1
  end

let remaining_argv _argv =
  let argc = CArray.length _argv in
  let optind = min !@optind argc in
  let argv = Array.of_list (CArray.to_list _argv) in
  Array.sub argv optind (argc - optind)

let apply_opt c = function
  | `None callback -> callback ()
  | `Optional callback ->
      if c = ':' then callback None else callback (Some (optarg ()))
  | `Required callback -> callback (optarg ())

let unknown_option _argv =
  let _optopt = !@optopt in
  let unknown =
    if _optopt <> Char.chr 0 then Printf.sprintf "-%c" _optopt
    else List.nth (CArray.to_list _argv) (!@optind - 1)
  in
  raise (Unknown_option unknown)

let check_result _argv c opts select =
  if c = '?' then unknown_option _argv;
  let _optopt = if c = ':' then !@optopt else c in
  let opt = List.find (select _optopt) opts in
  if c = ':' then begin
    match opt.arg with
      | `None _ -> assert false
      | `Optional _ -> ()
      | `Required _ -> raise (Missing_argument !@optopt)
  end;
  opt

let string_of_short_opt { name; arg } =
  let arg = match arg with `None _ -> "" | _ -> ":" in
  Printf.sprintf "%c%s" name arg

let getopt argv opts =
  let _argc = Array.length argv in
  let _argv = CArray.of_list string (Array.to_list argv) in
  let _short_opts = String.concat "" (List.map string_of_short_opt opts) in
  let _short_opts = ":" ^ _short_opts in
  let rec f () =
    let ret = getopt _argc (CArray.start _argv) _short_opts in
    if ret = -1 then remaining_argv _argv
    else begin
      let c = Char.chr ret in
      let { arg; _ } =
        check_result _argv c opts (fun c { name; _ } -> name = c)
      in
      apply_opt c arg;
      f ()
    end
  in
  f ()

let string_of_long_opt { name; arg } =
  let arg = match arg with `None _ -> "" | _ -> ":" in
  Printf.sprintf "%c%s" (snd name) arg

let long_opt_of_opt { name; arg } =
  let long_name, short_name = name in
  let _opt = make Option.t in
  setf _opt Option.name long_name;
  let has_arg = match arg with `None _ -> 0 | _ -> 1 in
  setf _opt Option.has_arg has_arg;
  setf _opt Option.flag (from_voidp int null);
  setf _opt Option._val (Char.code short_name);
  _opt

let getopt_long_generic ~call fn argv opts =
  let _argc = Array.length argv in
  let _argv = CArray.of_list string (Array.to_list argv) in
  let _short_opts = String.concat "" (List.map string_of_long_opt opts) in
  let _short_opts = ":" ^ _short_opts in
  let _long_opts = List.map long_opt_of_opt opts in
  let _long_opts = CArray.of_list Option.t _long_opts in
  let index = allocate int 0 in
  let rec f () =
    let ret =
      Posix_errno.raise_on_none ~call (fun () ->
          fn _argc (CArray.start _argv) _short_opts (CArray.start _long_opts)
            index)
    in
    if ret = -1 then remaining_argv _argv
    else begin
      let c = Char.chr ret in
      let { arg; _ } =
        check_result _argv c opts (fun c { name; _ } -> snd name = c)
      in
      apply_opt c arg;
      f ()
    end
  in
  f ()

let has_getopt_long = has_getopt_long ()
let has_getopt_long_only = has_getopt_long_only ()

let getopt_long x y z t u =
  let ret = getopt_long x y z t u in
  if has_getopt_long then Some ret else None

let getopt_long_only x y z t u =
  let ret = getopt_long_only x y z t u in
  if has_getopt_long_only then Some ret else None

let getopt_long = getopt_long_generic ~call:"getopt_long" getopt_long

let getopt_long_only =
  getopt_long_generic ~call:"getopt_long_only" getopt_long_only