Commit | Line | Data |
---|---|---|
feec80c3 C |
1 | (* |
2 | * optParse - Functions for parsing command line arguments. | |
3 | * Copyright (C) 2004 Bardur Arantsson | |
4 | * | |
5 | * Heavily influenced by the optparse.py module from the Python | |
6 | * standard library, but with lots of adaptation to the 'Ocaml Way' | |
7 | * | |
8 | * | |
9 | * This library is free software; you can redistribute it and/or | |
10 | * modify it under the terms of the GNU Lesser General Public | |
11 | * License as published by the Free Software Foundation; either | |
12 | * version 2.1 of the License, or (at your option) any later version, | |
13 | * with the special exception on linking described in file LICENSE. | |
14 | * | |
15 | * This library is distributed in the hope that it will be useful, | |
16 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
18 | * Lesser General Public License for more details. | |
19 | * | |
20 | * You should have received a copy of the GNU Lesser General Public | |
21 | * License along with this library; if not, write to the Free Software | |
22 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
23 | *) | |
24 | open Printf | |
25 | open ExtString | |
26 | open ExtList | |
27 | ||
28 | ||
29 | let terminal_width = | |
30 | try | |
31 | int_of_string (Sys.getenv "COLUMNS") (* Might as well use it if it's there... *) | |
32 | with | |
33 | Failure _ -> 80 | |
34 | | Not_found -> 80 | |
35 | ||
36 | module GetOpt = | |
37 | struct | |
38 | ||
39 | type action = string -> string list -> unit | |
40 | type long_opt = string * int * action | |
41 | type short_opt = char * int * action | |
42 | ||
43 | exception Error of (string * string) | |
44 | ||
45 | let split1 haystack needle = | |
46 | try | |
47 | let (h, x) = String.split haystack needle in h, [x] | |
48 | with | |
49 | Invalid_string -> haystack, [] | |
50 | ||
51 | let find_opt format_name options s = | |
52 | let rec loop l = | |
53 | match l with | |
54 | (x, y, z) :: t -> if x = s then x, y, z else loop t | |
55 | | [] -> raise (Error (format_name s, "no such option")) | |
56 | in | |
57 | loop options | |
58 | ||
59 | let find_short_opt options = find_opt (fun c -> sprintf "-%c" c) options | |
60 | ||
61 | let find_long_opt options = find_opt (fun s -> "--" ^ s) options | |
62 | ||
63 | let parse other find_short_opt find_long_opt args = | |
64 | let rec loop args = | |
65 | let rec gather_args name n args = | |
66 | try | |
67 | List.split_nth n args | |
68 | with | |
69 | List.Invalid_index _ -> | |
70 | raise (Error (name, "missing required arguments")) | |
71 | in | |
72 | let gather_long_opt s args = | |
73 | let (h, t) = split1 s "=" in | |
74 | let (_, nargs, action) = find_long_opt (String.slice ~first:2 h) in | |
75 | let (accum, args') = gather_args h (nargs - List.length t) args in | |
76 | action h (t @ accum); args' | |
77 | in | |
78 | let rec gather_short_opt_concat seen_args s k args = | |
79 | if k < String.length s then | |
80 | let ostr = sprintf "-%c" s.[k] | |
81 | and (_, nargs, action) = find_short_opt s.[k] in | |
82 | if nargs = 0 then | |
83 | begin | |
84 | action ostr []; | |
85 | gather_short_opt_concat seen_args s (k + 1) args | |
86 | end | |
87 | else if not seen_args then | |
88 | let (accum, args') = gather_args ostr nargs args in | |
89 | action ostr accum; gather_short_opt_concat true s (k + 1) args' | |
90 | else | |
91 | raise | |
92 | (Error | |
93 | (sprintf "-%c" s.[k], | |
94 | sprintf "option list '%s' already contains an option requiring an argument" | |
95 | s)) | |
96 | else args | |
97 | in | |
98 | let gather_short_opt s k args = | |
99 | let ostr = sprintf "-%c" s.[k] in | |
100 | let (_, nargs, action) = find_short_opt s.[k] in | |
101 | if nargs = 0 then gather_short_opt_concat false s k args | |
102 | else | |
103 | let (accum, args') = | |
104 | let h = String.slice ~first:(k+1) s in | |
105 | if String.length h = 0 then gather_args ostr nargs args | |
106 | else | |
107 | let (t, args'') = gather_args ostr (nargs - 1) args in | |
108 | h :: t, args'' | |
109 | in | |
110 | action ostr accum; args' | |
111 | in | |
112 | match args with | |
113 | [] -> [] | |
114 | | arg :: args' -> | |
115 | if arg = "--" then args' | |
116 | else if String.starts_with arg "--" then | |
117 | loop (gather_long_opt arg args') | |
118 | else if arg = "-" then begin other arg; loop args' end | |
119 | else if String.starts_with arg "-" then | |
120 | loop (gather_short_opt arg 1 args') | |
121 | else begin other arg; loop args' end | |
122 | in | |
123 | let args' = loop args in List.iter other args' | |
124 | end | |
125 | ||
126 | ||
127 | module Opt = | |
128 | struct | |
129 | ||
130 | exception No_value | |
131 | exception Option_error of string * string | |
132 | exception Option_help | |
133 | ||
134 | type 'a t = { | |
135 | option_set : string -> string list -> unit; | |
136 | option_set_value : 'a -> unit; | |
137 | option_get : unit -> 'a option; | |
138 | option_metavars : string list; | |
139 | option_defhelp : string option | |
140 | } | |
141 | ||
142 | let get opt = | |
143 | match opt.option_get () with | |
144 | Some x -> x | |
145 | | None -> raise No_value | |
146 | ||
147 | let set opt v = | |
148 | opt.option_set_value v | |
149 | ||
150 | let is_set opt = Option.is_some (opt.option_get ()) | |
151 | ||
152 | let opt opt = opt.option_get () | |
153 | ||
154 | let value_option metavar default coerce errfmt = | |
155 | let data = ref default in | |
156 | { | |
157 | option_metavars = [metavar]; | |
158 | option_defhelp = None; | |
159 | option_get = (fun _ -> !data); | |
160 | option_set_value = (fun x -> data := Some x); | |
161 | option_set = | |
162 | (fun option args -> | |
163 | let arg = List.hd args in | |
164 | try | |
165 | data := Some (coerce arg) | |
166 | with | |
167 | exn -> raise (Option_error (option, errfmt exn arg))) | |
168 | } | |
169 | ||
170 | let callback_option metavar coerce errfmt f = | |
171 | { | |
172 | option_metavars = [metavar]; | |
173 | option_defhelp = None; | |
174 | option_get = (fun _ -> Some ()); | |
175 | option_set_value = (fun () -> ()); | |
176 | option_set = | |
177 | (fun option args -> | |
178 | let arg = List.hd args in | |
179 | let datum = ref None in | |
180 | begin | |
181 | try | |
182 | datum := Some (coerce arg) | |
183 | with | |
184 | exn -> raise (Option_error (option, errfmt exn arg)) | |
185 | end; | |
186 | ||
187 | Option.may f !datum) | |
188 | } | |
189 | end | |
190 | ||
191 | module StdOpt = | |
192 | struct | |
193 | ||
194 | open Opt | |
195 | ||
196 | let store_const ?default const = | |
197 | let data = ref default in | |
198 | { | |
199 | option_metavars = []; | |
200 | option_defhelp = None; | |
201 | option_get = (fun _ -> !data); | |
202 | option_set_value = (fun x -> data := Some x); | |
203 | option_set = fun _ _ -> data := Some const | |
204 | } | |
205 | ||
206 | let store_true () = store_const ~default:false true | |
207 | ||
208 | let store_false () = store_const ~default:true false | |
209 | ||
210 | let int_option ?default ?(metavar = "INT") () = | |
211 | value_option metavar default int_of_string | |
212 | (fun _ s -> sprintf "invalid integer value '%s'" s) | |
213 | ||
214 | let int_callback ?(metavar = "INT") = | |
215 | callback_option metavar int_of_string | |
216 | (fun _ s -> sprintf "invalid integer value '%s'" s) | |
217 | ||
218 | let float_option ?default ?(metavar = "FLOAT") () = | |
219 | value_option metavar default float_of_string | |
220 | (fun _ s -> sprintf "invalid floating point value '%s'" s) | |
221 | ||
222 | let float_callback ?(metavar = "FLOAT") = | |
223 | callback_option metavar float_of_string | |
224 | (fun _ s -> sprintf "invalid floating point value '%s'" s) | |
225 | ||
226 | let str_option ?default ?(metavar = "STR") () = | |
227 | value_option metavar default (fun s -> s) (fun _ _ -> "cannot happen") | |
228 | ||
229 | let str_callback ?(metavar = "STR") = | |
230 | callback_option metavar (fun s -> s) (fun _ _ -> "cannot happen") | |
231 | ||
232 | let count_option ?(dest = ref 0) ?(increment = 1) () = | |
233 | { | |
234 | option_metavars = []; | |
235 | option_defhelp = None; | |
236 | option_get = (fun _ -> Some !dest); | |
237 | option_set_value = (fun x -> dest := x); | |
238 | option_set = fun _ _ -> dest := !dest + increment | |
239 | } | |
240 | ||
241 | let incr_option ?(dest = ref 0) = | |
242 | count_option ~dest ~increment:1 | |
243 | ||
244 | let decr_option ?(dest = ref 0) = | |
245 | count_option ~dest ~increment:(-1) | |
246 | ||
247 | let help_option () = | |
248 | { | |
249 | option_metavars = []; | |
250 | option_defhelp = Some "show this help message and exit"; | |
251 | option_get = (fun _ -> raise No_value); | |
252 | option_set_value = (fun _ -> ()); | |
253 | option_set = fun _ _ -> raise Option_help | |
254 | } | |
255 | ||
256 | let version_option vfunc = | |
257 | { | |
258 | option_metavars = []; | |
259 | option_defhelp = Some "show program's version and exit"; | |
260 | option_get = (fun _ -> raise No_value); | |
261 | option_set_value = (fun _ -> ()); | |
262 | option_set = fun _ _ -> print_endline (vfunc ()); exit 0 | |
263 | } | |
264 | end | |
265 | ||
266 | ||
267 | ||
268 | ||
269 | module Formatter = | |
270 | struct | |
271 | ||
272 | (* Note that the whitespace regexps must NOT treat the non-breaking | |
273 | space character as whitespace. *) | |
274 | let whitespace = "\t\n\013\014\r " | |
275 | ||
276 | let split_into_chunks s = | |
277 | let buf = Buffer.create (String.length s) in | |
278 | let flush () = | |
279 | let s = Buffer.contents buf | |
280 | in | |
281 | Buffer.clear buf; | |
282 | s | |
283 | in | |
284 | let rec loop state accum i = | |
285 | if (i<String.length s) then | |
286 | if ((state && not (String.contains whitespace s.[i])) || | |
287 | ((not state) && String.contains whitespace s.[i])) then | |
288 | if Buffer.length buf > 0 then | |
289 | loop (not state) (flush () :: accum) i | |
290 | else | |
291 | loop (not state) accum i | |
292 | else | |
293 | begin | |
294 | Buffer.add_char buf s.[i]; | |
295 | loop state accum (i+1) | |
296 | end | |
297 | else | |
298 | if Buffer.length buf > 0 then | |
299 | flush () :: accum | |
300 | else | |
301 | accum | |
302 | in | |
303 | List.rev (loop false [] 0) | |
304 | ||
305 | let is_whitespace s = | |
306 | let rec loop i = | |
307 | if i<String.length s then | |
308 | if String.contains whitespace s.[i] then | |
309 | loop (i+1) | |
310 | else | |
311 | false | |
312 | else | |
313 | true | |
314 | in | |
315 | loop 0 | |
316 | ||
317 | let expand_tabs ?(tab_size = 8) s = | |
318 | let len = String.length s in | |
319 | let spaces n = String.make n ' ' | |
320 | and b = Buffer.create len in | |
321 | let rec expand i col = | |
322 | if i < len then | |
323 | match s.[i] with | |
324 | '\t' -> | |
325 | let n = tab_size - col mod tab_size in | |
326 | Buffer.add_string b (spaces n); | |
327 | expand (i + 1) (col + n) | |
328 | | '\n' -> | |
329 | Buffer.add_string b "\n"; | |
330 | expand (i + 1) 0 | |
331 | | c -> | |
332 | Buffer.add_char b c; | |
333 | expand (i + 1) (col + 1) | |
334 | in | |
335 | expand 0 0; | |
336 | Buffer.contents b | |
337 | ||
338 | let wrap ?(initial_indent = 0) ?(subsequent_indent = 0) text _width = | |
339 | let wrap_chunks_line width acc = | |
340 | let rec wrap (chunks, cur_line, cur_len) = | |
341 | match chunks with | |
342 | [] -> [], cur_line, cur_len | |
343 | | hd :: tl -> | |
344 | let l = String.length hd in | |
345 | if cur_len + l <= width then | |
346 | wrap (tl, hd :: cur_line, cur_len + l) | |
347 | else chunks, cur_line, cur_len | |
348 | in | |
349 | wrap acc | |
350 | in | |
351 | let wrap_long_last_word width (chunks, cur_line, cur_len) = | |
352 | match chunks with | |
353 | [] -> [], cur_line, cur_len | |
354 | | hd :: tl -> | |
355 | let l = String.length hd in | |
356 | if l > width then | |
357 | match cur_line with | |
358 | [] -> tl, [hd], cur_len + l | |
359 | | _ -> chunks, cur_line, cur_len | |
360 | else chunks, cur_line, cur_len | |
361 | in | |
362 | let wrap_remove_last_ws (chunks, cur_line, cur_len) = | |
363 | match cur_line with | |
364 | [] -> chunks, cur_line, cur_len | |
365 | | hd :: tl -> | |
366 | if is_whitespace hd then chunks, tl, cur_len - String.length hd | |
367 | else chunks, cur_line, cur_len | |
368 | in | |
369 | let rec wrap_chunks_lines chunks lines = | |
370 | let indent = | |
371 | match lines with | |
372 | [] -> initial_indent | |
373 | | _ -> subsequent_indent | |
374 | in | |
375 | let width = _width - indent in | |
376 | match chunks with | |
377 | hd :: tl -> | |
378 | if is_whitespace hd && lines <> [] then wrap_chunks_lines tl lines | |
379 | else (* skip *) | |
380 | let (chunks', cur_line, _) = | |
381 | wrap_remove_last_ws | |
382 | (wrap_long_last_word width | |
383 | (wrap_chunks_line width (chunks, [], 0))) | |
384 | in | |
385 | wrap_chunks_lines chunks' | |
386 | ((String.make indent ' ' ^ | |
387 | String.concat "" (List.rev cur_line)) :: | |
388 | lines) | |
389 | | [] -> List.rev lines | |
390 | in | |
391 | let chunks = split_into_chunks (expand_tabs text) in | |
392 | wrap_chunks_lines chunks [] | |
393 | ||
394 | ||
395 | let fill ?(initial_indent = 0) ?(subsequent_indent = 0) text width = | |
396 | String.concat "\n" (wrap ~initial_indent ~subsequent_indent text width) | |
397 | ||
398 | ||
399 | ||
400 | type t = { | |
401 | indent : unit -> unit; | |
402 | dedent : unit -> unit; | |
403 | format_usage : string -> string; | |
404 | format_heading : string -> string; | |
405 | format_description : string -> string; | |
406 | format_option : char list * string list -> string list -> | |
407 | string option -> string | |
408 | } | |
409 | ||
410 | let format_option_strings short_first (snames, lnames) metavars = | |
411 | let metavar = String.concat " " metavars in | |
412 | let lopts = | |
413 | List.map | |
414 | (match metavar with | |
415 | "" -> (fun z -> sprintf "--%s" z) | |
416 | | _ -> fun z -> sprintf "--%s=%s" z metavar) | |
417 | lnames | |
418 | and sopts = List.map (fun x -> sprintf "-%c%s" x metavar) snames in | |
419 | match short_first with | |
420 | true -> String.concat ", " (sopts @ lopts) | |
421 | | false -> String.concat ", " (lopts @ sopts) | |
422 | ||
423 | ||
424 | let indented_formatter ?level:(extlevel = ref 0) | |
425 | ?indent:(extindent = ref 0) ?(indent_increment = 2) | |
426 | ?(max_help_position = 24) ?(width = terminal_width - 1) | |
427 | ?(short_first = true) () = | |
428 | let indent = ref 0 | |
429 | and level = ref 0 in | |
430 | let help_position = ref max_help_position | |
431 | and help_width = ref (width - max_help_position) in | |
432 | { | |
433 | indent = | |
434 | (fun () -> | |
435 | indent := !indent + indent_increment; | |
436 | level := !level + 1; | |
437 | extindent := !indent; | |
438 | extlevel := !level); | |
439 | ||
440 | dedent = | |
441 | (fun () -> | |
442 | indent := !indent - indent_increment; | |
443 | level := !level - 1; | |
444 | assert (!level >= 0); | |
445 | extindent := !indent; | |
446 | extlevel := !level); | |
447 | ||
448 | format_usage = (fun usage -> sprintf "usage: %s\n" usage); | |
449 | ||
450 | format_heading = | |
451 | (fun heading -> sprintf "%*s%s:\n\n" !indent "" heading); | |
452 | ||
453 | format_description = | |
454 | (fun description -> | |
455 | let x = | |
456 | fill ~initial_indent:(!indent) ~subsequent_indent:(!indent) | |
457 | description (width - !indent) | |
458 | in | |
459 | if not (String.ends_with x "\n") then x ^ "\n\n" else x ^ "\n"); | |
460 | ||
461 | format_option = | |
462 | fun names metavars help -> | |
463 | let opt_width = !help_position - !indent - 2 in | |
464 | let opt_strings = | |
465 | format_option_strings short_first names metavars | |
466 | in | |
467 | let buf = Buffer.create 256 in | |
468 | let indent_first = | |
469 | if String.length opt_strings > opt_width then | |
470 | begin | |
471 | bprintf buf "%*s%s\n" !indent "" opt_strings; !help_position | |
472 | end | |
473 | else | |
474 | begin | |
475 | bprintf buf "%*s%-*s " !indent "" opt_width opt_strings; 0 | |
476 | end | |
477 | in | |
478 | Option.may | |
479 | (fun option_help -> | |
480 | let lines = wrap option_help !help_width in | |
481 | match lines with | |
482 | h :: t -> | |
483 | bprintf buf "%*s%s\n" indent_first "" h; | |
484 | List.iter | |
485 | (fun x -> bprintf buf "%*s%s\n" !help_position "" x) t | |
486 | | [] -> ()) | |
487 | help; | |
488 | ||
489 | let contents = | |
490 | Buffer.contents buf | |
491 | in | |
492 | if String.length contents > 0 && not (String.ends_with contents "\n") then | |
493 | contents ^ "\n" | |
494 | else | |
495 | contents | |
496 | } | |
497 | ||
498 | let titled_formatter ?(level = ref 0) ?(indent = ref 0) | |
499 | ?(indent_increment = 0) ?(max_help_position = 24) | |
500 | ?(width = terminal_width - 1) ?(short_first = true) | |
501 | () = | |
502 | let formatter = | |
503 | indented_formatter ~level ~indent ~indent_increment ~max_help_position | |
504 | ~width ~short_first () | |
505 | in | |
506 | let format_heading h = | |
507 | let c = | |
508 | match !level with | |
509 | 0 -> '=' | |
510 | | 1 -> '-' | |
511 | | _ -> failwith "titled_formatter: Too much indentation" | |
512 | in | |
513 | sprintf "%*s%s\n%*s%s\n\n" !indent "" (String.capitalize h) !indent "" | |
514 | (String.make (String.length h) c) | |
515 | in | |
516 | let format_usage usage = | |
517 | sprintf "%s %s\n" (format_heading "Usage") usage | |
518 | in | |
519 | { formatter with | |
520 | format_usage = format_usage; | |
521 | format_heading = format_heading | |
522 | } | |
523 | end | |
524 | ||
525 | ||
526 | ||
527 | open Opt | |
528 | open Formatter | |
529 | ||
530 | module OptParser = | |
531 | struct | |
532 | ||
533 | exception Option_conflict of string | |
534 | ||
535 | type group = { | |
536 | og_heading : string; | |
537 | og_description : string option; | |
538 | og_options : | |
539 | ((char list * string list) * string list * string option) RefList.t; | |
540 | og_children : group RefList.t | |
541 | } | |
542 | ||
543 | type t = { | |
544 | op_usage : string; | |
545 | op_suppress_usage : bool; | |
546 | op_prog : string; | |
547 | ||
548 | op_formatter : Formatter.t; | |
549 | ||
550 | op_long_options : GetOpt.long_opt RefList.t; | |
551 | op_short_options : GetOpt.short_opt RefList.t; | |
552 | ||
553 | op_groups : group | |
554 | } | |
555 | ||
556 | let unprogify optparser s = | |
557 | (snd (String.replace ~str:s ~sub:"%prog" ~by:optparser.op_prog)) | |
558 | ||
559 | let add optparser ?(group = optparser.op_groups) ?help ?(hide = false) | |
560 | ?short_name ?(short_names = []) ?long_name ?(long_names = []) opt = | |
561 | let lnames = | |
562 | match long_name with | |
563 | None -> long_names | |
564 | | Some x -> x :: long_names | |
565 | and snames = | |
566 | match short_name with | |
567 | None -> short_names | |
568 | | Some x -> x :: short_names | |
569 | in | |
570 | if lnames = [] && snames = [] then | |
571 | failwith "Options must have at least one name" | |
572 | else | |
573 | (* Checking for duplicates: *) | |
574 | let snames' = | |
575 | List.fold_left (fun r (x, _, _) -> x :: r) [] | |
576 | (RefList.to_list optparser.op_short_options) | |
577 | and lnames' = | |
578 | List.fold_left (fun r (x, _, _) -> x :: r) [] | |
579 | (RefList.to_list optparser.op_long_options) | |
580 | in | |
581 | let sconf = | |
582 | List.filter (fun e -> List.exists (( = ) e) snames') snames | |
583 | and lconf = | |
584 | List.filter (fun e -> List.exists (( = ) e) lnames') lnames | |
585 | in | |
586 | if List.length sconf > 0 then | |
587 | raise (Option_conflict (sprintf "-%c" (List.hd sconf))) | |
588 | else if List.length lconf > 0 then | |
589 | raise (Option_conflict (sprintf "--%s" (List.hd lconf))); | |
590 | ||
591 | (* Add to display list. *) | |
592 | if not hide then | |
593 | RefList.add group.og_options | |
594 | ((snames, lnames), opt.option_metavars, | |
595 | (match help with | |
596 | None -> opt.option_defhelp | |
597 | | Some _ -> help)); | |
598 | ||
599 | (* Getopt: *) | |
600 | let nargs = List.length opt.option_metavars in | |
601 | List.iter | |
602 | (fun short -> | |
603 | RefList.add optparser.op_short_options | |
604 | (short, nargs, opt.option_set)) | |
605 | snames; | |
606 | List.iter | |
607 | (fun long -> | |
608 | RefList.add optparser.op_long_options | |
609 | (long, nargs, opt.option_set)) | |
610 | lnames | |
611 | ||
612 | let add_group optparser ?(parent = optparser.op_groups) ?description heading = | |
613 | let g = | |
614 | { | |
615 | og_heading = heading; | |
616 | og_description = description; | |
617 | og_options = RefList.empty (); | |
618 | og_children = RefList.empty () | |
619 | } | |
620 | in | |
621 | RefList.add parent.og_children g; g | |
622 | ||
623 | let make ?(usage = "%prog [options]") ?description ?version | |
624 | ?(suppress_usage = false) ?(suppress_help = false) ?prog | |
625 | ?(formatter = Formatter.indented_formatter ()) () = | |
626 | let optparser = | |
627 | { | |
628 | op_usage = usage; | |
629 | op_suppress_usage = suppress_usage; | |
630 | op_prog = Option.default (Filename.basename Sys.argv.(0)) prog; | |
631 | op_formatter = formatter; | |
632 | op_short_options = RefList.empty (); | |
633 | op_long_options = RefList.empty (); | |
634 | op_groups = { | |
635 | og_heading = "options"; | |
636 | og_options = RefList.empty (); | |
637 | og_children = RefList.empty (); | |
638 | og_description = description | |
639 | } | |
640 | } | |
641 | in | |
642 | Option.may (* Add version option? *) | |
643 | (fun version -> | |
644 | add optparser ~long_name:"version" | |
645 | (StdOpt.version_option | |
646 | (fun () -> unprogify optparser version))) | |
647 | version; | |
648 | if not suppress_help then (* Add help option? *) | |
649 | add optparser ~short_name:'h' ~long_name:"help" | |
650 | (StdOpt.help_option ()); | |
651 | ||
652 | optparser | |
653 | ||
654 | let format_usage optparser eol = | |
655 | match optparser.op_suppress_usage with | |
656 | true -> "" | |
657 | | false -> | |
658 | unprogify optparser | |
659 | (optparser.op_formatter.format_usage optparser.op_usage) ^ eol | |
660 | ||
661 | let error optparser ?(chn = stderr) ?(status = 1) message = | |
662 | fprintf chn "%s%s: %s\n" (format_usage optparser "\n") optparser.op_prog | |
663 | message; | |
664 | flush chn; | |
665 | exit status | |
666 | ||
667 | let usage optparser ?(chn = stdout) () = | |
668 | let rec loop g = | |
669 | (* Heading: *) | |
670 | output_string chn | |
671 | (optparser.op_formatter.format_heading g.og_heading); | |
672 | ||
673 | optparser.op_formatter.indent (); | |
674 | (* Description: *) | |
675 | Option.may | |
676 | (fun x -> | |
677 | output_string chn (optparser.op_formatter.format_description x)) | |
678 | g.og_description; | |
679 | (* Options: *) | |
680 | RefList.iter | |
681 | (fun (names, metavars, help) -> | |
682 | output_string chn | |
683 | (optparser.op_formatter.format_option names metavars help)) | |
684 | g.og_options; | |
685 | (* Child groups: *) | |
686 | output_string chn "\n"; | |
687 | RefList.iter loop g.og_children; | |
688 | ||
689 | optparser.op_formatter.dedent () | |
690 | in | |
691 | output_string chn (format_usage optparser "\n"); | |
692 | loop optparser.op_groups; | |
693 | flush chn | |
694 | ||
695 | let parse optparser ?(first = 0) ?last argv = | |
696 | let args = RefList.empty () | |
697 | and n = | |
698 | match last with | |
699 | None -> Array.length argv - first | |
700 | | Some m -> m - first + 1 | |
701 | in | |
702 | begin | |
703 | try | |
704 | GetOpt.parse (RefList.push args) | |
705 | (GetOpt.find_short_opt | |
706 | (RefList.to_list optparser.op_short_options)) | |
707 | (GetOpt.find_long_opt (RefList.to_list optparser.op_long_options)) | |
708 | (Array.to_list (Array.sub argv first n)) | |
709 | with | |
710 | GetOpt.Error (opt, errmsg) -> | |
711 | error optparser (sprintf "option '%s': %s" opt errmsg) | |
712 | | Option_error (opt, errmsg) -> | |
713 | error optparser (sprintf "option '%s': %s" opt errmsg) | |
714 | | Option_help -> usage optparser (); exit 0 | |
715 | end; | |
716 | List.rev (RefList.to_list args) | |
717 | ||
718 | let parse_argv optparser = | |
719 | parse optparser ~first:1 Sys.argv | |
720 | end |