uarg.ml (3899B)
1 (* Unison file synchronizer: src/ubase/uarg.ml *) 2 (* Copyright 1999-2020, Benjamin C. Pierce (see COPYING for details) *) 3 4 (* by Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 5 (* Slightly modified by BCP, July 1999 *) 6 7 type spec = 8 | Unit of (unit -> unit) (* Call the function with unit argument *) 9 | Set of bool ref (* Set the reference to true *) 10 | Clear of bool ref (* Set the reference to false *) 11 | Bool of (bool -> unit) (* Pass true to the function *) 12 | String of (string -> unit) (* Call the function with a string argument *) 13 | Int of (int -> unit) (* Call the function with an int argument *) 14 | Float of (float -> unit) (* Call the function with a float argument *) 15 | Rest of (string -> unit) (* Stop interpreting keywords and call the 16 function with each remaining argument *) 17 18 exception Bad of string 19 20 type error = 21 | Unknown of string 22 | Wrong of string * string * string (* option, actual, expected *) 23 | Missing of string 24 | Message of string 25 26 open Printf 27 28 let rec assoc3 x l = 29 match l with 30 | [] -> raise Not_found 31 | (y1, y2, y3)::t when y1 = x -> y2 32 | _::t -> assoc3 x t 33 ;; 34 35 let usage speclist errmsg = 36 printf "%s\n" errmsg; 37 Safelist.iter 38 (function (key, _, doc) -> 39 if String.length doc > 0 && doc.[0] <> '*' 40 then printf " %s %s\n" key doc) 41 (Safelist.rev speclist) 42 ;; 43 44 let current = ref 0;; 45 46 let eprintf fmt = 47 Printf.ksprintf (fun s -> 48 if System.has_stderr ~info:s then Printf.eprintf "%s" s else exit 2) fmt 49 50 let verify_stdout () = 51 if not (System.has_stdout ~info:"") then exit 37 52 53 let parse speclist anonfun errmsg = 54 let argv = System.argv () in 55 let initpos = !current in 56 let stop error = 57 let progname = 58 if initpos < Array.length argv then argv.(initpos) else "(?)" in 59 begin match error with 60 | Unknown s when s = "-help" -> verify_stdout () 61 | Unknown s -> 62 eprintf "%s: unknown option `%s'.\n" progname s 63 | Missing s -> 64 eprintf "%s: option `%s' needs an argument.\n" progname s 65 | Wrong (opt, arg, expected) -> 66 eprintf "%s: wrong argument `%s'; option `%s' expects %s.\n" 67 progname arg opt expected 68 | Message s -> 69 eprintf "%s: %s.\n" progname s 70 end; 71 usage speclist errmsg; 72 exit 2; 73 in 74 let l = Array.length argv in 75 incr current; 76 while !current < l do 77 let ss = argv.(!current) in 78 if String.length ss >= 1 && String.get ss 0 = '-' then begin 79 let (s, v) = Util.splitAtChar ss '=' in 80 let arg conv mesg = 81 match v with 82 None -> 83 if !current + 1 >= l then stop (Missing s) else 84 let a = argv.(!current+1) in 85 incr current; 86 (try conv a with Failure _ -> stop (Wrong (s, a, mesg))) 87 | Some a -> (try conv a with Failure _ -> stop (Wrong (s, a, mesg))) in 88 let action = 89 try assoc3 s speclist 90 with Not_found -> stop (Unknown s) 91 and catch f a = 92 try f a 93 with Invalid_argument s -> raise (Failure s) 94 in 95 begin try 96 match action with 97 | Unit f -> f (); 98 | Set r -> r := true; 99 | Clear r -> r := false; 100 | Bool f -> 101 begin match v with 102 None -> f true 103 | Some _ -> f (arg (catch bool_of_string) "a boolean") 104 end 105 | String f -> f (arg (fun s-> s) "") 106 | Int f -> f (arg (catch int_of_string) "an integer") 107 | Float f -> f (arg (catch float_of_string) "a float") 108 | Rest f -> 109 while !current < l-1 do 110 f argv.(!current+1); 111 incr current; 112 done; 113 with Bad m -> stop (Message m); 114 end; 115 incr current; 116 end else begin 117 (try anonfun ss with Bad m -> stop (Message m)); 118 incr current; 119 end; 120 done; 121 ;;