src/utils/lib/options.ml4

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20
  21     (* Simple options:
  22   This will enable very simple configuration, by a mouse-based configurator.
  23   Options will be defined by a special function, which will also check
  24   if a value has been provided  by the user in its .gwmlrc file.
  25   The .gwmlrc will be created by a dedicated tool, which could be used
  26   to generate both .gwmlrc and .efunsrc files.
  27
  28 *)
  29
  30 open Printf2
  31
  32 type option_value =
  33     Module of option_module
  34   | StringValue of string
  35   | IntValue of int64
  36   | FloatValue of float
  37   | List of option_value list
  38   | SmallList of option_value list
  39   | OnceValue of option_value
  40   | DelayedValue of (out_channel -> string -> unit)
  41 and option_module = (string * option_value) list
  42
  43 exception SideEffectOption
  44 exception OptionNotFound
  45
  46 type 'a option_class =
  47   { class_name : string;
  48     from_value : option_value -> 'a;
  49     to_value : 'a -> option_value;
  50     mutable class_hooks : ('a option_record -> unit) list;
  51     mutable string_wrappers : (('a -> string) * (string -> 'a)) option;
  52   }
  53 and 'a option_record =
  54   {
  55     option_class : 'a option_class;
  56     mutable option_value : 'a;
  57     option_name : string list;
  58     mutable option_desc : string;
  59     option_help : string;
  60     option_default : 'a;
  61     mutable option_hooks : (unit -> unit) list;
  62     option_section : options_section;
  63     option_advanced : bool;
  64     option_restart : bool;
  65     option_public : bool;
  66     option_internal : bool;
  67     }
  68 and options_file =
  69   { mutable file_name : string;
  70     mutable file_sections : options_section list;
  71     mutable file_rc : option_module;
  72     mutable file_pruned : bool;
  73
  74     mutable file_before_save_hook : (unit -> unit);
  75     mutable file_after_save_hook : (unit -> unit);
  76     mutable file_after_load_hook : (unit -> unit);
  77     }
  78 and options_section = {
  79     section_name : string list;
  80     section_help : string;
  81     section_file : options_file;
  82     mutable section_options : Obj.t option_record list;
  83   }
  84
  85 let file_section file section_name section_help =
  86   let s = {
  87       section_name = section_name;
  88       section_help = section_help;
  89       section_file = file;
  90       section_options = [];
  91     }
  92   in
  93   file.file_sections <- file.file_sections @ [s];
  94   s
  95
  96 let create_options_file name =
  97   let file =
  98     {
  99       file_name = name;
 100       file_sections = [];
 101       file_rc = [];
 102       file_pruned = false;
 103
 104       file_before_save_hook = (fun _ -> ());
 105       file_after_save_hook = (fun _ -> ());
 106       file_after_load_hook = (fun _ -> ());
 107       }
 108   in
 109   ignore (file_section file ["Header"] "These options must be read first");
 110   file
 111
 112 let set_options_file opfile name = opfile.file_name <- name
 113 let print_options_not_found = ref false
 114
 115 let define_option_class
 116   (class_name : string) (from_value : option_value -> 'a)
 117     (to_value : 'a -> option_value) =
 118   let c =
 119     {class_name = class_name; from_value = from_value; to_value = to_value;
 120      class_hooks = []; string_wrappers = None;}
 121   in
 122   c
 123
 124
 125 let rec find_value list m =
 126   match list with
 127     [] -> raise Not_found
 128   | name :: tail ->
 129       let m = List.assoc name m in
 130       match m, tail with
 131         _, [] -> m
 132       | Module m, _ :: _ -> find_value tail m
 133       | _ -> raise Not_found
 134
 135 let find_value list m =
 136   try find_value list m with
 137     _ -> raise OptionNotFound
 138
 139 let prune_file file = file.file_pruned <- true
 140
 141 let define_simple_option
 142     normalp (section : options_section) (option_name : string list) desc
 143   restart public internal
 144   (option_help : string) (option_class : 'a option_class)
 145   (default_value : 'a) (advanced : bool) =
 146   let desc = match desc with None -> "" | Some s -> s in
 147   let o =
 148     { option_name = option_name; option_help = option_help;
 149       option_class = option_class; option_value = default_value;
 150       option_default = default_value;
 151       option_hooks = []; option_section = section;
 152       option_restart = (match restart with None -> false | Some v -> v);
 153       option_public = (match public with None -> false | Some v -> v);
 154       option_internal = (match internal with None -> false | Some v -> v);
 155       option_advanced = advanced; option_desc = desc; }
 156   in
 157   section.section_options <-
 158     section.section_options @ [ (Obj.magic o : Obj.t option_record) ];
 159   o.option_value <-
 160     begin try
 161       o.option_class.from_value (
 162         find_value option_name section.section_file.file_rc)
 163     with
 164       OptionNotFound -> default_value
 165     | e ->
 166         lprintf "Options.define_option, for option %s: "
 167           (match option_name with
 168             [] -> "???"
 169           | name :: _ -> name);
 170         lprintf "%s\n" (Printexc2.to_string e);
 171         default_value
 172   end;
 173   o
 174
 175 let define_header_option
 176   opfile option_name option_help option_class default_value =
 177   define_simple_option false (List.hd opfile.file_sections)
 178   option_name None None None None option_help option_class
 179     default_value false
 180
 181 let define_option opfile option_name ?desc ?restart ?public ?internal option_help option_class default_value =
 182   define_simple_option true opfile option_name desc restart public internal option_help option_class
 183     default_value false
 184
 185 let define_expert_option
 186   opfile option_name ?desc ?restart ?public ?internal option_help option_class default_value =
 187   define_simple_option true opfile option_name desc restart public internal option_help option_class
 188     default_value true
 189
 190
 191 open Genlex2
 192
 193 let once_values = Hashtbl.create 13
 194 let once_values_counter = ref 0
 195 let once_values_rev = Hashtbl.create 13
 196
 197 let lexer = make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","; "."; "@"]
 198
 199 let rec parse_gwmlrc = parser
 200 | [< id = parse_id; 'Kwd "="; v = parse_option ;
 201       eof = parse_gwmlrc >] -> (id, v) :: eof
 202 | [< >] -> []
 203
 204 and parse_option = parser
 205 | [< 'Kwd "{"; v = parse_gwmlrc; 'Kwd "}" >] -> Module v
 206 | [< 'Ident s >] -> StringValue s
 207 | [< 'String s >] -> StringValue s
 208 | [< 'Int i >] -> IntValue i
 209 | [< 'Float f >] -> FloatValue  f
 210 | [< 'Kwd "@"; 'Int i; v = parse_once_value i >] -> OnceValue v
 211 | [< 'Char c >] -> StringValue (let s = String.create 1 in s.[0] <- c; s)
 212 | [< 'Kwd "["; v = parse_list [] >] -> List v
 213 | [< 'Kwd "("; v = parse_list [] >] -> List v
 214
 215 and parse_once_value i = parser
 216     [< 'Kwd "@" >] ->
 217     begin
 218       try Hashtbl.find once_values i with Not_found ->
 219           lprintf "Error in saved file: @%Ld@ not defined\n" i;
 220           exit 70
 221     end
 222 |  [< 'Kwd "="; v = parse_option >] ->
 223     begin
 224       Hashtbl.add once_values i v;
 225       v
 226     end
 227
 228 and parse_id = parser
 229     [< 'Ident s >] -> s
 230 |   [< 'String s >] -> s
 231
 232 and parse_list list = parser
 233     [< 'Kwd ";"; strm >] -> parse_list (list) strm
 234 |   [< 'Kwd ","; strm >] -> parse_list (list) strm
 235 |   [< 'Kwd "."; strm >] -> parse_list (list) strm
 236 |   [< v = parse_option; strm >] -> parse_list (v :: list) strm
 237 |   [< 'Kwd "]" >] -> List.rev list
 238 |   [< 'Kwd ")" >] -> List.rev list
 239
 240
 241 let exec_hooks o =
 242   List.iter
 243     (fun f ->
 244        try f () with
 245          _ -> ())
 246     o.option_hooks
 247
 248 let exec_chooks o =
 249   List.iter
 250     (fun f ->
 251        try f o with
 252          _ -> ())
 253     o.option_class.class_hooks
 254
 255 let really_load filename sections =
 256   let temp_file = filename ^ ".tmp" in
 257   if Sys.file_exists temp_file then
 258     begin
 259       lprintf "File %s exists\n" temp_file;
 260       lprintf "An error may have occurred during previous configuration save.\n";
 261       lprintf "Please, check your configurations files, and rename/remove this file\n";
 262       lprintf "before restarting\n";
 263       exit 70
 264     end;
 265   Unix2.tryopen_read filename (fun ic ->
 266     let s = Stream.of_channel ic in
 267     try
 268       let stream = lexer s in
 269       Hashtbl.clear once_values;
 270       let list =
 271         try
 272           parse_gwmlrc stream
 273         with e ->
 274           lprintf "Syntax error while parsing file %s at pos %d:(%s)\n"
 275             filename (Stream.count s) (Printexc2.to_string e);
 276           lprintf "it seems that %s is corrupt,\n" filename;
 277           lprintf "try to use a backup from %s\n"
 278             (Filename.concat (Sys.getcwd ()) "old_config");
 279           exit 70 in
 280       Hashtbl.clear once_values;
 281       let affect_option o =
 282         try
 283           (try
 284             o.option_value <-
 285               o.option_class.from_value (find_value o.option_name list)
 286           with SideEffectOption -> ());
 287           exec_chooks o;
 288           exec_hooks o
 289         with
 290           | SideEffectOption -> ()
 291           | OptionNotFound ->
 292               if !print_options_not_found then
 293                 begin
 294                   lprintf "Option ";
 295                   List.iter (fun s -> lprintf "%s " s) o.option_name;
 296                   lprintf "not found in %s\n" filename;
 297                 end
 298           | e ->
 299               lprintf "Exception: %s while handling option:"
 300                 (Printexc2.to_string e);
 301               List.iter (fun s -> lprintf "%s " s) o.option_name;
 302               lprintf "\n";
 303               lprintf "  in %s\n" filename;
 304               lprintf "Aborting\n.";
 305               exit 70
 306       in
 307
 308 (* The options are affected by sections, from the first defined one to
 309 the last defined one ("defined" in the order of the program execution).
 310   Don't change this. *)
 311       List.iter (fun s ->
 312           List.iter affect_option s.section_options) sections;
 313       list
 314     with e ->
 315       lprintf "Error %s in %s\n" (Printexc2.to_string e) filename;
 316       [])
 317
 318
 319 let exit_exn = Exit
 320
 321
 322 let unsafe_get = String.unsafe_get
 323 external is_printable : char -> bool = "caml_is_printable"
 324 let unsafe_set = String.unsafe_set
 325
 326 let escaped s =
 327   let n = ref 0 in
 328   for i = 0 to String.length s - 1 do
 329     n :=
 330       !n +
 331         (match unsafe_get s i with
 332            '"' | '\\' -> 2
 333          | '\n' | '\t' -> 1
 334          | c -> if is_printable c then 1 else 4)
 335   done;
 336   if !n = String.length s then s
 337   else
 338     let s' = String.create !n in
 339     n := 0;
 340     for i = 0 to String.length s - 1 do
 341       begin match unsafe_get s i with
 342         '"' | '\\' as c -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c
 343       | '\n' | '\t' as c -> unsafe_set s' !n c
 344       | c ->
 345           if is_printable c then unsafe_set s' !n c
 346           else
 347             let a = int_of_char c in
 348             unsafe_set s' !n '\\';
 349             incr n;
 350             unsafe_set s' !n (char_of_int (48 + a / 100));
 351             incr n;
 352             unsafe_set s' !n (char_of_int (48 + a / 10 mod 10));
 353             incr n;
 354             unsafe_set s' !n (char_of_int (48 + a mod 10))
 355       end;
 356       incr n
 357     done;
 358     s'
 359
 360 let safe_string s =
 361   if s = "" then "\"\""
 362   else
 363     try
 364       match s.[0] with
 365         'a'..'z' | 'A'..'Z' ->
 366           for i = 1 to String.length s - 1 do
 367             match s.[i] with
 368               'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> ()
 369             | _ -> raise exit_exn
 370           done;
 371           s
 372       | _ ->
 373           if Int64.to_string (Int64.of_string s) = s ||
 374              string_of_float (float_of_string s) = s
 375           then
 376             s
 377           else raise exit_exn
 378     with
 379       _ -> Printf.sprintf "\"%s\"" (escaped s)
 380
 381 let with_help = ref false
 382 let save_private = ref false
 383
 384 let tabulate s = String2.replace s '\n' "\n\t"
 385
 386 let rec save_module indent oc list =
 387   let subm = ref [] in
 388   List.iter
 389     (fun (name, help, restart, internal, value) ->
 390        match name with
 391          [] -> assert false
 392        | [name] ->
 393            if !with_help && help <> "" then
 394              Printf.fprintf oc "\n\t(* %s *)\n" (tabulate help);
 395            if restart then
 396              Printf.fprintf oc "\t(* changing this option requires restart of MLDonkey core *)\n";
 397            if internal then
 398              Printf.fprintf oc "\t(* Do not change this option, internal use only! *)\n";
 399            Printf.fprintf oc "%s %s = " indent (safe_string name);
 400            save_value indent oc value;
 401            Printf.fprintf oc "\n"
 402        | m :: tail ->
 403            let p =
 404              try List.assoc m !subm with
 405                e -> let p = ref [] in subm := (m, p) :: !subm; p
 406            in
 407            p := (tail, help, restart, internal, value) :: !p)
 408     list;
 409   List.iter
 410     (fun (m, p) ->
 411        Printf.fprintf oc "%s %s = {\n" indent (safe_string m);
 412        save_module (indent ^ "  ") oc !p;
 413        Printf.fprintf oc "%s}\n" indent)
 414     !subm
 415 and save_list indent oc list =
 416   match list with
 417     [] -> ()
 418   | [v] -> save_value indent oc v
 419   | v :: tail ->
 420       save_value indent oc v; Printf.fprintf oc ", "; save_list indent oc tail
 421 and save_list_nl indent oc list =
 422   match list with
 423     [] -> ()
 424   | [v] -> Printf.fprintf oc "\n%s" indent; save_value indent oc v
 425   | v :: tail ->
 426       Printf.fprintf oc "\n%s" indent;
 427       save_value indent oc v;
 428       Printf.fprintf oc ";";
 429       save_list_nl indent oc tail
 430 and save_value indent oc v =
 431   match v with
 432     StringValue s -> Printf.fprintf oc "%s" (safe_string s)
 433   | IntValue i -> Printf.fprintf oc "%s" (Int64.to_string i)
 434   | FloatValue f -> Printf.fprintf oc "%F" f
 435   | List l ->
 436       Printf.fprintf oc "[";
 437       save_list_nl (indent ^ "  ") oc l;
 438       Printf.fprintf oc "]"
 439   | DelayedValue f -> f oc indent
 440   | SmallList l ->
 441       Printf.fprintf oc "(";
 442       save_list (indent ^ "  ") oc l;
 443       Printf.fprintf oc ")"
 444   | Module m ->
 445       Printf.fprintf oc "{";
 446       save_module_fields (indent ^ "  ") oc m;
 447       Printf.fprintf oc "}"
 448   | OnceValue v ->
 449       try
 450         let i = Hashtbl.find once_values_rev v in Printf.fprintf oc "@%Ld@" i
 451       with
 452         Not_found ->
 453           incr once_values_counter;
 454           let i = Int64.of_int !once_values_counter in
 455           Hashtbl.add once_values_rev v i;
 456           Printf.fprintf oc "@%Ld = " i;
 457           save_value indent oc v
 458 and save_module_fields indent oc m =
 459   match m with
 460     [] -> ()
 461   | (name, v) :: tail ->
 462       Printf.fprintf oc "%s %s = " indent (safe_string name);
 463       save_value indent oc v;
 464       Printf.fprintf oc "\n";
 465       save_module_fields indent oc tail
 466
 467 let options_file_name f = f.file_name
 468
 469 let load opfile =
 470   (try
 471     opfile.file_rc <-
 472       really_load opfile.file_name opfile.file_sections;
 473   with
 474   | Not_found | Sys_error _ -> ());
 475   opfile.file_after_load_hook ()
 476
 477 let append opfile filename =
 478   try
 479     opfile.file_rc <-
 480       really_load filename opfile.file_sections @
 481         opfile.file_rc
 482   with
 483     Not_found -> lprintf "No %s found\n" filename
 484
 485 let ( !! ) o = o.option_value
 486 let ( =:= ) o v = o.option_value <- v; exec_chooks o; exec_hooks o
 487
 488 let value_to_stringoption v =
 489   match v with
 490     StringValue s -> if s = "None" then None else Some s
 491   | _ -> failwith "Not a string option"
 492
 493 let stringoption_to_value v =
 494   match v with
 495     None -> StringValue "None"
 496   | Some s -> StringValue s
 497
 498 let rec value_to_string v =
 499   match v with
 500     StringValue s -> s
 501   | IntValue i -> Int64.to_string i
 502   | FloatValue f -> string_of_float f
 503   | OnceValue v -> value_to_string v
 504   | _ -> failwith "Not a string option"
 505
 506 let safe_value_to_string v =
 507   match v with
 508     StringValue s -> s
 509   | IntValue i -> Int64.to_string i
 510   | FloatValue f -> string_of_float f
 511   | OnceValue v -> value_to_string v
 512   | _ -> "NaS"
 513
 514 let string_to_value s = StringValue s
 515
 516 let rec value_to_int64 v =
 517   match v with
 518     StringValue s -> Int64.of_string s
 519   | IntValue i -> i
 520   | FloatValue i -> Int64.of_float i
 521   | OnceValue v -> value_to_int64 v
 522   | _ -> failwith "Options: not an int option"
 523
 524 let value_to_int v = Int64.to_int (value_to_int64 v)
 525 let int_to_value i = IntValue (Int64.of_int i)
 526 let int64_to_value i = IntValue i
 527
 528 let percent_to_value i = IntValue (Int64.of_int i)
 529 let value_to_percent v =
 530   match Int64.to_int (value_to_int64 v) with
 531     v when v < 0 -> 0
 532   | v when v > 100 -> 100
 533   | v -> v
 534
 535 let port_to_value i = IntValue (Int64.of_int i)
 536 let value_to_port v =
 537   match Int64.to_int (value_to_int64 v) with
 538   | v when v < 0 -> 2000 + Random.int 40000
 539   | v when v > 65535 -> 2000 + Random.int 40000
 540   | v -> v
 541
 542 (* The Pervasives version is too restrictive *)
 543 let bool_of_string s =
 544   match String.lowercase s with
 545     "true" -> true
 546   | "false" -> false
 547   | "yes" -> true
 548   | "no" -> false
 549   | "y" -> true
 550   | "n" -> false
 551   | _ -> invalid_arg "bool_of_string"
 552
 553 let rec value_to_bool v =
 554   match v with
 555     StringValue s -> bool_of_string s
 556   | IntValue v when v = Int64.zero -> false
 557   | IntValue v when v = Int64.one -> true
 558   | OnceValue v -> value_to_bool v
 559   | _ -> failwith "Options: not a bool option"
 560 let bool_to_value i = StringValue (string_of_bool i)
 561
 562 let rec value_to_float v =
 563   match v with
 564     StringValue s -> float_of_string s
 565   | FloatValue f -> f
 566   | OnceValue v -> value_to_float v
 567   | _ -> failwith "Options: not a float option"
 568
 569 let float_to_value i = FloatValue i
 570
 571 let rec value_to_string2 v =
 572   match v with
 573     List [s1; s2] | SmallList [s1; s2] ->
 574       value_to_string s1, value_to_string s2
 575   | OnceValue v -> value_to_string2 v
 576   | _ -> failwith "Options: not a string2 option"
 577
 578 let string2_to_value (s1, s2) = SmallList [StringValue s1; StringValue s2]
 579
 580 let rec value_to_list v2c v =
 581   match v with
 582     List l | SmallList l -> List.rev (List.rev_map v2c l)
 583   | OnceValue v -> value_to_list v2c v
 584   | StringValue s ->
 585       failwith
 586         (Printf.sprintf "Options: not a list option (StringValue [%s])" s)
 587   | FloatValue _ -> failwith "Options: not a list option (FloatValue)"
 588   | IntValue _ -> failwith "Options: not a list option (IntValue)"
 589   | Module _ -> failwith "Options: not a list option (Module)"
 590   | DelayedValue _ -> failwith "Options: not a list option (Delayed)"
 591
 592 let rec value_to_hasharray v2c v =
 593   match v with
 594     List l ->
 595       let hash = Array.init 256 (fun _ -> Hashtbl.create 10) in
 596       List.iter
 597         (fun a ->
 598            let (num, md4, peer) = v2c a in Hashtbl.add hash.(num) md4 peer)
 599         (List.rev l);
 600       hash
 601   | OnceValue v -> value_to_hasharray v2c v
 602   | _ -> failwith (Printf.sprintf "Options: not a list option for list2")
 603
 604 let rec value_to_safelist v2c v =
 605   match v with
 606     List l | SmallList l ->
 607       let rec iter list left =
 608         match left with
 609           [] -> list
 610         | x :: tail ->
 611             let list =
 612               try v2c x :: list with
 613                 _ -> list
 614             in
 615             iter list tail
 616       in
 617       List.rev (iter [] (List.rev l))
 618   | OnceValue v -> value_to_safelist v2c v
 619   | StringValue s ->
 620       failwith
 621         (Printf.sprintf "Options: not a list option (StringValue [%s])" s)
 622   | FloatValue _ -> failwith "Options: not a list option (FloatValue)"
 623   | IntValue _ -> failwith "Options: not a list option (IntValue)"
 624   | Module _ -> failwith "Options: not a list option (Module)"
 625   | DelayedValue _ -> failwith "Options: not a list option (Delayed)"
 626
 627 let rec value_to_intmap f v2c v =
 628   match v with
 629     List l | SmallList l ->
 630       let rec iter map left =
 631         match left with
 632           [] -> map
 633         | x :: tail ->
 634             let map =
 635               try let v = v2c x in let num = f v in Intmap.add num v map with
 636                 _ -> map
 637             in
 638             iter map tail
 639       in
 640       iter Intmap.empty l
 641   | OnceValue v -> value_to_intmap f v2c v
 642   | StringValue s ->
 643       failwith
 644         (Printf.sprintf "Options: not a list option (StringValue [%s])" s)
 645   | FloatValue _ -> failwith "Options: not a list option (FloatValue)"
 646   | IntValue _ -> failwith "Options: not a list option (IntValue)"
 647   | Module _ -> failwith "Options: not a list option (Module)"
 648   | DelayedValue _ -> failwith "Options: not a list option (Delayed)"
 649
 650 let rec value_to_listiter v2c v =
 651   match v with
 652     List l | SmallList l ->
 653       List.iter
 654         (fun v ->
 655            try ignore (v2c v) with
 656              SideEffectOption -> ())
 657         l;
 658       raise SideEffectOption
 659   | OnceValue v -> value_to_listiter v2c v
 660   | StringValue s ->
 661       failwith
 662         (Printf.sprintf "Options: not a list option (StringValue [%s])" s)
 663   | FloatValue _ -> failwith "Options: not a list option (FloatValue)"
 664   | IntValue _ -> failwith "Options: not a list option (IntValue)"
 665   | Module _ -> failwith "Options: not a list option (Module)"
 666   | DelayedValue _ -> failwith "Options: not a list option (Delayed)"
 667
 668 let rec convert_list c2v l res =
 669   match l with
 670     [] -> List.rev res
 671   | v :: list ->
 672       match
 673         try Some (c2v v) with
 674           e ->
 675             lprintf "Exception %s in Options.convert_list\n"
 676               (Printexc2.to_string e);
 677             None
 678       with
 679         None -> convert_list c2v list res
 680       | Some v -> convert_list c2v list (v :: res)
 681
 682 let option_to_value c2v o =
 683   match o with
 684     None -> StringValue ""
 685   | Some c -> c2v c
 686
 687 let rec value_to_option v2c v =
 688   match v with
 689     StringValue "" -> None
 690   | OnceValue v -> value_to_option v2c v
 691   | _ -> Some (v2c v)
 692
 693 let save_delayed_list_value oc indent c2v =
 694   let indent = indent ^ "  " in
 695   fun v ->
 696     try
 697       let v = c2v v in
 698       Printf.fprintf oc "\n%s" indent;
 699       save_value indent oc v;
 700       Printf.fprintf oc ";"
 701     with _ -> ()
 702
 703 let list_to_value c2v l =
 704   DelayedValue
 705     (fun oc indent ->
 706        Printf.fprintf oc "[";
 707        List.iter (save_delayed_list_value oc indent c2v) l;
 708        Printf.fprintf oc "]")
 709
 710 let intmap_to_value name c2v map =
 711   DelayedValue
 712     (fun oc indent ->
 713        let save = save_delayed_list_value oc indent c2v in
 714        Printf.fprintf oc "[";
 715        Intmap.iter (fun _ v -> save v) map;
 716        Printf.fprintf oc "]")
 717
 718 let hasharray_to_value x c2v l =
 719   DelayedValue
 720     (fun oc indent ->
 721        Printf.fprintf oc "[";
 722        let save = save_delayed_list_value oc indent c2v in
 723        for i = 0 to Array.length l - 1 do
 724          Hashtbl.iter (fun a b -> save (0, x, b)) l.(i)
 725        done;
 726        Printf.fprintf oc "]")
 727
 728 let smalllist_to_value c2v l = SmallList (convert_list c2v l [])
 729
 730 let value_to_path v =
 731   List.map Filename2.from_string
 732     (let rec iter v =
 733        match v with
 734          StringValue s -> Filepath.string_to_colonpath s
 735        | OnceValue v -> iter v
 736        | List l ->
 737            List.map
 738              (fun v ->
 739                 match v with
 740                   StringValue s -> Filename2.from_string s
 741                 | _ -> failwith "Options: not a path option")
 742              l
 743        | _ -> failwith "Options: not path bool option"
 744      in
 745      iter v)
 746
 747 let path_to_value list =
 748   StringValue (Filepath.colonpath_to_string (List.map Filename2.to_string list))
 749
 750 let string_option =
 751   define_option_class "String" value_to_string string_to_value
 752 let color_option = define_option_class "Color" value_to_string string_to_value
 753 let font_option = define_option_class "Font" value_to_string string_to_value
 754
 755 let int_option = define_option_class "Int" value_to_int int_to_value
 756 let int64_option = define_option_class "Int64" value_to_int64 int64_to_value
 757 let percent_option = define_option_class "Int" value_to_percent percent_to_value
 758 let port_option = define_option_class "Int" value_to_port port_to_value
 759
 760 let bool_option = define_option_class "Bool" value_to_bool bool_to_value
 761 let float_option = define_option_class "Float" value_to_float float_to_value
 762 let path_option = define_option_class "Path" value_to_path path_to_value
 763
 764 let string2_option =
 765   define_option_class "String2" value_to_string2 string2_to_value
 766
 767 let option_option cl =
 768   define_option_class (cl.class_name ^ " Option")
 769     (value_to_option cl.from_value) (option_to_value cl.to_value)
 770
 771 let list_option cl =
 772   define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value)
 773     (list_to_value cl.to_value)
 774
 775 let value_to_array from_value a =
 776   Array.of_list (value_to_list from_value a)
 777 let array_to_value to_value v =
 778   list_to_value to_value (Array.to_list v)
 779
 780 let array_option cl =
 781   define_option_class (cl.class_name ^ " Array")
 782     (fun v -> Array.of_list (value_to_list cl.from_value v))
 783     (fun v -> list_to_value cl.to_value (Array.to_list v))
 784
 785 let hasharray_option x cl =
 786   define_option_class "Hashtable array" (value_to_hasharray cl.from_value)
 787     (hasharray_to_value x cl.to_value)
 788
 789 let safelist_option cl =
 790   define_option_class (cl.class_name ^ " List")
 791     (value_to_safelist cl.from_value)
 792     (list_to_value cl.to_value)
 793
 794 let intmap_option f cl =
 795   define_option_class (cl.class_name ^ " Intmap")
 796     (value_to_intmap f cl.from_value)
 797     (intmap_to_value cl.class_name cl.to_value)
 798
 799 let listiter_option cl =
 800   define_option_class (cl.class_name ^ " List")
 801     (value_to_listiter cl.from_value)
 802     (list_to_value cl.to_value)
 803
 804 let smalllist_option cl =
 805   define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value)
 806     (smalllist_to_value cl.to_value)
 807
 808 let to_value cl = cl.to_value
 809 let from_value cl = cl.from_value
 810
 811 let rec value_to_sum l v =
 812   match v with
 813     StringValue s -> List.assoc s l
 814   | OnceValue v -> value_to_sum l v
 815   | _ -> failwith "Options: not a sum option"
 816
 817 let sum_to_value l v = StringValue (List.assq v l)
 818
 819 let sum_option l =
 820   let ll = List.map (fun (a1, a2) -> a2, a1) l in
 821   define_option_class "Sum" (value_to_sum l) (sum_to_value ll)
 822
 823 let option_to_value o =
 824   o.option_name, o.option_help,
 825   o.option_restart, o.option_internal,
 826   (try o.option_class.to_value o.option_value with
 827      e ->
 828        lprintf "Error while saving option \"%s\": %s\n"
 829          (try List.hd o.option_name with
 830             _ -> "???")
 831          (Printexc2.to_string e);
 832        StringValue "")
 833
 834 let string_of_string_list list =
 835   let rec iter s list =
 836     match list with
 837       [] -> s
 838     | ss :: tail ->
 839         iter (Printf.sprintf "%s.%s" s ss) tail
 840   in
 841   match list with
 842     [] -> ""
 843   | s :: tail -> iter s tail
 844
 845 let title_opfile = ref true;;
 846
 847 let save opfile =
 848   opfile.file_before_save_hook ();
 849
 850   let old_config_dir = "old_config" in
 851   if not (Sys.file_exists old_config_dir) then Unix.mkdir old_config_dir 0o755;
 852
 853   let filename = opfile.file_name in
 854   let old_file = Filename.concat old_config_dir filename in
 855
 856   try
 857     Unix2.with_remove (filename ^ ".tmp") begin fun temp_file ->
 858     Unix2.tryopen_write temp_file (fun oc ->
 859       (* race! *)
 860       if !save_private then (try Unix.chmod temp_file 0o600 with _ -> ());
 861       once_values_counter := 0;
 862       title_opfile := true;
 863       Hashtbl.clear once_values_rev;
 864       let advanced = ref false in
 865       List.iter (fun s ->
 866         let options = List.filter (fun o ->
 867           if o.option_advanced then advanced := true;
 868           not o.option_advanced) s.section_options in
 869         if options <> [] then begin
 870           if s.section_name <> [] then begin
 871             Printf.fprintf oc "\n\n";
 872             Printf.fprintf oc "    (************************************)\n";
 873             if !title_opfile then begin
 874               Printf.fprintf oc "    (*   Never edit options files when  *)\n";
 875               Printf.fprintf oc "    (*       the daemon is running      *)\n";
 876               Printf.fprintf oc "    (************************************)\n";
 877               title_opfile := false;
 878             end;
 879             Printf.fprintf oc "    (* SECTION : %s *)\n" (string_of_string_list s.section_name);
 880             Printf.fprintf oc "    (* %s *)\n" s.section_help;
 881             Printf.fprintf oc "    (************************************)\n";
 882             Printf.fprintf oc "\n\n";
 883           end;
 884           save_module "" oc (List.map option_to_value options)
 885         end
 886       ) opfile.file_sections;
 887       if !advanced then begin
 888         Printf.fprintf oc "\n\n\n";
 889         Printf.fprintf oc "(*****************************************************************)\n";
 890         Printf.fprintf oc "(*                                                               *)\n";
 891         Printf.fprintf oc "(*                       ADVANCED OPTIONS                        *)\n";
 892         Printf.fprintf oc "(*                                                               *)\n";
 893         Printf.fprintf oc "(*        All the options after this line are for the expert     *)\n";
 894         Printf.fprintf oc "(*        user. Do not modify them if you are not   sure.        *)\n";
 895         Printf.fprintf oc "(*                                                               *)\n";
 896         Printf.fprintf oc "(*****************************************************************)\n";
 897         Printf.fprintf oc "\n\n\n";
 898         List.iter (fun s ->
 899           let options = List.filter (fun o -> o.option_advanced)
 900             s.section_options in
 901           if options = [] then () else let _ = () in
 902           Printf.fprintf oc "\n\n";
 903           Printf.fprintf oc "    (************************************)\n";
 904
 905           Printf.fprintf oc "    (* SECTION : %s FOR EXPERTS *)\n" (string_of_string_list s.section_name);
 906           Printf.fprintf oc "    (* %s *)\n" s.section_help;
 907           Printf.fprintf oc "    (************************************)\n";
 908           Printf.fprintf oc "\n\n";
 909           save_module "" oc (List.map option_to_value options)
 910         ) opfile.file_sections;
 911       end;
 912       if not opfile.file_pruned then
 913         begin
 914           let rem = ref [] in
 915           Printf.fprintf oc "\n(*\n The following options are not used (errors, obsolete, ...) \n*)\n";
 916           List.iter
 917             (fun (name, value) ->
 918               try
 919                 List.iter
 920                   (fun s ->
 921                     List.iter
 922                       (fun o ->
 923                         match o.option_name with
 924                             n :: _ -> if n = name then raise Exit
 925                           | _ -> ())
 926                       s.section_options)
 927                   opfile.file_sections;
 928                 rem := (name, value) :: !rem;
 929                 Printf.fprintf oc "%s = " (safe_string name);
 930                 save_value "  " oc value;
 931                 Printf.fprintf oc "\n"
 932               with
 933                 | Exit -> ()
 934                 | e ->
 935                     lprintf "Exception %s in Options.save\n"
 936                       (Printexc2.to_string e);
 937             )
 938             opfile.file_rc;
 939           opfile.file_rc <- !rem
 940         end;
 941       flush oc;
 942       Unix2.fsync (Unix.descr_of_out_channel oc);
 943       Hashtbl.clear once_values_rev);
 944     (try
 945       begin
 946         try
 947           Unix2.rename filename old_file
 948         with Unix.Unix_error(Unix.ENOENT, _, _) -> ();
 949       end;
 950       Unix2.rename temp_file filename
 951      with e ->
 952         lprintf_nl "[Opt] exception %s while saving %s" (Printexc2.to_string e) filename
 953     );
 954     end; (* remove temp_file *)
 955     opfile.file_after_save_hook ();
 956   with e ->
 957     opfile.file_after_save_hook ();
 958     raise e
 959
 960 let save_with_help opfile =
 961   with_help := true;
 962   ( try save opfile with _ -> () );
 963   with_help := false
 964
 965 let save_with_help_private opfile =
 966   with_help := true;
 967   save_private := true;
 968   begin try save opfile with
 969     _ -> ()
 970   end;
 971   with_help := false;
 972   save_private := false
 973
 974 let option_hook option f = option.option_hooks <- f :: option.option_hooks
 975
 976 let class_hook option_class f =
 977   option_class.class_hooks <- f :: option_class.class_hooks
 978
 979 let rec iter_order f list =
 980   match list with
 981     [] -> ()
 982   | v :: tail -> f v; iter_order f tail
 983
 984 let help oc opfile =
 985   List.iter (fun s ->
 986       List.iter
 987         (fun o ->
 988           Printf.fprintf oc "OPTION \"";
 989           begin match o.option_name with
 990               [] -> Printf.fprintf oc "???"
 991             | [name] -> Printf.fprintf oc "%s" name
 992             | name :: tail ->
 993                 Printf.fprintf oc "%s" name;
 994                 iter_order (fun name -> Printf.fprintf oc ":%s" name) o.option_name
 995           end;
 996           Printf.fprintf oc "\" (TYPE \"%s\"): %s\n   CURRENT: \n"
 997             o.option_class.class_name o.option_help;
 998           begin try
 999               once_values_counter := 0;
1000               Hashtbl.clear once_values_rev;
1001               save_value "" oc (o.option_class.to_value o.option_value)
1002             with
1003               _ -> ()
1004           end;
1005           Printf.fprintf oc "\n")
1006       s.section_options;
1007   ) opfile.file_sections;
1008   flush oc
1009
1010
1011 let tuple2_to_value (c1, c2) (a1, a2) =
1012   SmallList [to_value c1 a1; to_value c2 a2]
1013
1014 let rec value_to_tuple2 (c1, c2 as cs) v =
1015   match v with
1016     List [v1; v2] -> from_value c1 v1, from_value c2 v2
1017   | SmallList [v1; v2] -> from_value c1 v1, from_value c2 v2
1018   | OnceValue v -> value_to_tuple2 cs v
1019   | List l | SmallList l ->
1020       lprintf "list of %d\n" (List.length l);
1021       failwith "Options: not a tuple2 list option"
1022   | _ -> failwith "Options: not a tuple2 option"
1023
1024 let tuple2_option p =
1025   define_option_class "tuple2_option" (value_to_tuple2 p) (tuple2_to_value p)
1026
1027 let tuple3_to_value (c1, c2, c3) (a1, a2, a3) =
1028   SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3]
1029 let rec value_to_tuple3 (c1, c2, c3 as cs) v =
1030   match v with
1031     List [v1; v2; v3] -> from_value c1 v1, from_value c2 v2, from_value c3 v3
1032   | SmallList [v1; v2; v3] ->
1033       from_value c1 v1, from_value c2 v2, from_value c3 v3
1034   | OnceValue v -> value_to_tuple3 cs v
1035   | _ -> failwith "Options: not a tuple3 option"
1036
1037 let tuple3_option p =
1038   define_option_class "tuple3_option" (value_to_tuple3 p) (tuple3_to_value p)
1039
1040 let tuple4_to_value (c1, c2, c3, c4) (a1, a2, a3, a4) =
1041   SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3; to_value c4 a4]
1042 let rec value_to_tuple4 (c1, c2, c3, c4 as cs) v =
1043   match v with
1044     List [v1; v2; v3; v4] | SmallList [v1; v2; v3; v4] ->
1045       from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4
1046   | OnceValue v -> value_to_tuple4 cs v
1047   | _ -> failwith "Options: not a tuple4 option"
1048
1049 let tuple4_option p =
1050   define_option_class "tuple4_option" (value_to_tuple4 p) (tuple4_to_value p)
1051
1052
1053 let value_to_filename v =
1054   Filename2.from_string
1055     (match v with
1056        StringValue s -> s
1057      | _ -> failwith "Options: not a filename option")
1058
1059 let filename_to_value v = StringValue (Filename2.to_string v)
1060
1061 let filename_option =
1062   define_option_class "Filename" value_to_filename filename_to_value
1063
1064 let shortname o = String.concat ":" o.option_name
1065 let get_class o = o.option_class
1066 let get_help o =
1067   let help = o.option_help in if help = "" then "No Help Available" else help
1068 let advanced o = o.option_advanced
1069
1070 let get_option opfile name =
1071 (*  lprintf "get_option [%s]\n" name;*)
1072   let rec iter name list sections =
1073     match list with
1074     | o :: list -> if o.option_name = name then o else
1075           iter name list sections
1076     | [] ->
1077         match sections with
1078           [] ->
1079             prerr_endline
1080               (Printf.sprintf "option [%s] not_found in %s"
1081                 (String.concat ";" name) opfile.file_name);
1082             raise Not_found
1083         | s :: tail ->
1084             iter name s.section_options tail
1085   in
1086   iter [name] [] opfile.file_sections
1087
1088
1089 let set_simple_option opfile name v =
1090   let o = get_option opfile name in
1091   begin match o.option_class.string_wrappers with
1092     None -> o.option_value <- o.option_class.from_value (string_to_value v)
1093   | Some (_, from_string) -> o.option_value <- from_string v
1094   end;
1095   exec_chooks o;
1096   exec_hooks o
1097
1098 let get_simple_option opfile name =
1099   let o = get_option opfile name in
1100   match o.option_class.string_wrappers with
1101     None -> safe_value_to_string (o.option_class.to_value o.option_value)
1102   | Some (to_string, _) -> to_string o.option_value
1103
1104 let set_string_wrappers o to_string from_string =
1105   o.string_wrappers <- Some (to_string, from_string)
1106
1107 let option_type o = (get_class o).class_name
1108
1109 let once_value v = OnceValue v
1110
1111 let restore_default o =
1112   o =:= o.option_default
1113 let set_option_desc o s =
1114   o.option_desc <- s
1115
1116 module M = struct
1117
1118     type option_info = {
1119         option_name : string;
1120         option_shortname : string;
1121         option_desc : string;
1122         option_value : string;
1123         option_help : string;
1124         option_advanced : bool;
1125         option_default : string;
1126         option_type : string;
1127         option_restart : bool;
1128         option_public : bool;
1129         option_internal : bool;
1130       }
1131
1132   end
1133
1134 let string_of_option_value o v =
1135   match o.option_class.string_wrappers with
1136     None ->
1137       value_to_string (o.option_class.to_value v)
1138   | Some (to_string, _) -> to_string v
1139
1140 let tuple2_to_value f x =
1141   let (v1, v2) = f x in
1142   SmallList [v1; v2]
1143
1144 let value_to_tuple2 f x =
1145   match value_to_list (fun id -> id) x with
1146     [v1;v2] -> f (v1, v2)
1147   | _ -> assert false
1148
1149 let strings_of_option prefix o =
1150   match o.option_name with
1151     [] | _ :: _ :: _ -> failwith "Complex option"
1152   | [name] ->
1153       let desc = if o.option_desc = "" then name else o.option_desc in
1154       {
1155         M.option_name = Printf.sprintf "%s%s" prefix name;
1156         M.option_shortname = name;
1157         M.option_desc = desc;
1158         M.option_value = string_of_option_value o o.option_value;
1159         M.option_default = string_of_option_value o o.option_default;
1160         M.option_advanced = o.option_advanced;
1161         M.option_help = o.option_help;
1162         M.option_type = o.option_class.class_name;
1163         M.option_restart = o.option_restart;
1164         M.option_public = o.option_public;
1165         M.option_internal = o.option_internal;
1166       }
1167
1168 let simple_options prefix opfile admin =
1169   let list = ref [] in
1170   List.iter (fun s ->
1171       List.iter
1172         (fun o ->
1173           if admin || o.option_public then
1174           try list := strings_of_option prefix o :: !list  with _ -> ())
1175       s.section_options)
1176   opfile.file_sections;
1177   List.rev !list
1178
1179 let simple_args prefix opfile =
1180   List2.tail_map
1181     (fun oi ->
1182        "-" ^ oi.M.option_name,
1183        Arg.String
1184          (fun s ->
1185             lprintf_nl "Setting option %s" oi.M.option_name;
1186             set_simple_option opfile oi.M.option_name s),
1187        Printf.sprintf "<string> : \t%s (current: %s)"
1188          oi.M.option_help oi.M.option_value)
1189     (simple_options prefix opfile true)
1190
1191 let prefixed_args prefix file =
1192   List.map
1193     (fun (s, f, h) ->
1194        let s = String.sub s 1 (String.length s - 1) in
1195        Printf.sprintf "-%s:%s" prefix s, f, h)
1196     (simple_args "" file)
1197
1198 let sections file = file.file_sections
1199 let section_name s = string_of_string_list s.section_name
1200
1201 let strings_of_section_options prefix s =
1202   let list = ref [] in
1203   List.iter
1204   (fun o ->
1205       try list := strings_of_option prefix o :: !list  with _ -> ())
1206   s.section_options;
1207   List.rev !list
1208
1209 type option_info = M.option_info = {
1210     option_name : string;
1211     option_shortname : string;
1212     option_desc : string;
1213     option_value : string;
1214     option_help : string;
1215     option_advanced : bool;
1216     option_default : string;
1217     option_type : string;
1218     option_restart : bool;
1219     option_public : bool;
1220     option_internal : bool;
1221   }
1222
1223 let iter_section f s =
1224   List.iter f s.section_options
1225
1226 let iter_file f file =
1227   List.iter (iter_section f) file.file_sections
1228
1229 let strings_of_option o = strings_of_option "" o
1230
1231 let set_after_load_hook file f =
1232   file.file_after_load_hook <- f
1233
1234 let set_after_save_hook file f =
1235   file.file_after_save_hook <- f
1236
1237 let set_before_save_hook file f =
1238   file.file_before_save_hook <- f
1239