prefs.ml (28769B)
1 (* Unison file synchronizer: src/ubase/prefs.ml *) 2 (* $I3: Copyright 1999-2002 (see COPYING for details) $ *) 3 4 let debug = Util.debug "prefs" 5 6 type 'a t = 7 { mutable value : 'a; defaultValue : 'a; mutable names : string list; 8 mutable setInProfile : bool } 9 10 let read p = p.value 11 12 let set p v = p.setInProfile <- true; p.value <- v 13 14 let overrideDefault p v = if not p.setInProfile then p.value <- v 15 16 let name p = p.names 17 18 let readDefault p = p.defaultValue 19 20 let rawPref default name = 21 { value = default; defaultValue = default; names = [name]; 22 setInProfile = false } 23 24 (* ------------------------------------------------------------------------- *) 25 26 let profileName = ref None 27 let profileFiles = ref [] 28 29 let profilePathname ?(add_ext=true) n = 30 let f = Util.fileInUnisonDir n in 31 if (not add_ext) || System.file_exists f then f 32 else Util.fileInUnisonDir (n ^ ".prf") 33 34 let thePrefsFile () = 35 match !profileName with 36 None -> raise (Util.Transient("No preference file has been specified")) 37 | Some(n) -> profilePathname n 38 39 let profileUnchanged () = 40 List.for_all 41 (fun (path, info) -> 42 try 43 let newInfo = System.stat path in 44 newInfo.Unix.LargeFile.st_kind = Unix.S_REG && 45 info.Unix.LargeFile.st_mtime = newInfo.Unix.LargeFile.st_mtime && 46 info.Unix.LargeFile.st_size = newInfo.Unix.LargeFile.st_size 47 with Unix.Unix_error _ -> 48 false) 49 !profileFiles 50 51 (* ------------------------------------------------------------------------- *) 52 53 (* When preferences change, we need to dump them out to the file we loaded *) 54 (* them from. This is accomplished by associating each preference with a *) 55 (* printing function. *) 56 57 let printers = ref ([] : (string * (unit -> string list)) list) 58 59 let addprinter name f = printers := (name, f) :: !printers 60 61 (* ---------------------------------------------------------------------- *) 62 63 (* When we load a new profile, we need to reset all preferences to their *) 64 (* default values. Each preference has a resetter for doing this. *) 65 66 let resetters = ref [] 67 68 let addresetter f = resetters := f :: !resetters 69 70 let resetToDefaults () = 71 Safelist.iter (fun f -> f()) !resetters; profileFiles := [] 72 73 (* ------------------------------------------------------------------------- *) 74 75 (* When the server starts up, we need to ship it the current state of all *) 76 (* the preference settings. This is accomplished by dumping them on the *) 77 (* client side and loading on the server side; as each preference is *) 78 (* created, a dumper (marshaler) and a loader (parser) are added to the list *) 79 (* kept here... *) 80 81 type dumpedPrefs = (string * bool * string) list 82 83 let mdumpedPrefs = Umarshal.(list (prod3 string bool string id id)) 84 85 let dumpers = ref ([] : (string * bool * (unit->bool) * (int->string)) list) 86 let loaders = ref (Util.StringMap.empty : (int->string->unit) Util.StringMap.t) 87 let ignored = ref [] 88 89 let adddumper name optional send f = 90 dumpers := (name,optional,send,f) :: !dumpers 91 92 let addloader name f = 93 loaders := Util.StringMap.add name f !loaders 94 95 let addignored name = 96 ignored := name :: !ignored 97 98 let dump rpcVer = 99 Safelist.filter (fun (_, _, sf, _) -> sf ()) !dumpers 100 |> Safelist.map (fun (name, opt, _, f) -> (name, opt, f rpcVer)) 101 102 let load d rpcVer = 103 Safelist.iter 104 (fun (name, opt, dumpedval) -> 105 match 106 try Some (Util.StringMap.find name !loaders) with Not_found -> None 107 with 108 Some loaderfn -> 109 loaderfn rpcVer dumpedval 110 | None -> 111 if not opt && not (Safelist.mem name !ignored) then 112 raise (Util.Fatal 113 ("Preference "^name^" not found: \ 114 inconsistent Unison versions??"))) 115 d 116 117 (* For debugging *) 118 let dumpPrefsToStderr() = 119 Printf.eprintf "Preferences:\n"; 120 Safelist.iter 121 (fun (name,f) -> 122 Safelist.iter 123 (fun s -> Printf.eprintf "%s = %s\n" name s) 124 (f())) 125 !printers 126 127 (* ------------------------------------------------------------------------- *) 128 129 (* Each preference is associated with a handler function taking an argument *) 130 (* of appropriate type. These functions should raise IllegalValue if they *) 131 (* are invoked with a value that falls outside the range they expect. This *) 132 (* exception will be caught within the preferences module and used to *) 133 (* generate an appropriate usage message. *) 134 exception IllegalValue of string 135 136 (* aliasMap: prefName -> prefName *) 137 let aliasMap = ref (Util.StringMap.empty : string Util.StringMap.t) 138 139 let canonicalName nm = 140 try Util.StringMap.find nm !aliasMap with Not_found -> nm 141 142 type topic = [ 143 | `General 144 | `Sync 145 | `Syncprocess 146 | `Syncprocess_CLI 147 | `CLI 148 | `GUI 149 | `Remote 150 | `Archive ] 151 152 type group = [ 153 | `Basic of topic 154 | `Advanced of topic 155 | `Expert 156 | `Internal of 157 [ `Pseudo | `Devel | `Other ] ] 158 159 let isInternal = function 160 | `Internal _ -> true 161 | _ -> false 162 163 let topic = function 164 | `General -> "General" 165 | `Sync -> "What to sync" 166 | `Syncprocess -> "How to sync" 167 | `Syncprocess_CLI -> "How to sync (text interface (CLI) only)" 168 | `CLI -> "Text interface (CLI)" 169 | `GUI -> "Graphical interface (GUI)" 170 | `Remote -> "Remote connections" 171 | `Archive -> "Archive management" 172 173 type typ = 174 [`BOOL | `INT | `STRING | `STRING_LIST | `BOOLDEF | `CUSTOM | `UNKNOWN] 175 176 type apref = 177 { 178 category : group; 179 doc : string; 180 pspec : Uarg.spec; 181 fulldoc : string; 182 typ : typ; 183 cli_only : bool; 184 deprec : bool; 185 } 186 187 (* prefs: prefName -> apref *) 188 let prefs = 189 ref (Util.StringMap.empty : apref Util.StringMap.t) 190 191 let typ nm = 192 try let {typ; _} = Util.StringMap.find nm !prefs in typ with 193 | Not_found -> `UNKNOWN 194 195 let documentation nm = 196 try 197 let {category; doc; fulldoc; deprec; _} = Util.StringMap.find nm !prefs in 198 if isInternal category then raise Not_found; 199 let doc = 200 if not deprec then doc 201 else "(Deprecated) " ^ doc 202 in 203 let fulldoc = 204 if not deprec then fulldoc 205 else "{\\em (Deprecated)} " ^ fulldoc 206 in 207 (doc, fulldoc) 208 with Not_found -> 209 ("", "") 210 211 let category nm = 212 try 213 let {category; _} = Util.StringMap.find nm !prefs in 214 Some category 215 with Not_found -> 216 None 217 218 let list include_cli_only = 219 List.sort String.compare 220 (Util.StringMap.fold 221 (fun nm {category; cli_only; _} l -> 222 if (not cli_only || include_cli_only) && not (isInternal category) then 223 nm :: l 224 else l) 225 !prefs []) 226 227 (* aliased pref has *-prefixed doc and empty fulldoc *) 228 let alias pref newname = 229 (* pref must have been registered, so name pref is not empty, and will be *) 230 (* found in the map, no need for catching exception *) 231 let pref' = Util.StringMap.find (Safelist.hd (name pref)) !prefs in 232 let pref' = {pref' with category = `Internal `Other; doc = "*"; fulldoc = ""} in 233 prefs := Util.StringMap.add newname pref' !prefs; 234 let () = 235 try 236 let loader = Util.StringMap.find (Safelist.hd (name pref)) !loaders in 237 addloader newname loader 238 with Not_found -> () 239 in 240 aliasMap := Util.StringMap.add newname (Safelist.hd (name pref)) !aliasMap; 241 pref.names <- newname :: pref.names 242 243 let combine_pspec f = function 244 | Uarg.Bool f' -> Uarg.Bool (fun x -> f' x; f ()) 245 | Uarg.String f' -> Uarg.String (fun x -> f' x; f ()) 246 | Uarg.Int f' -> Uarg.Int (fun x -> f' x; f ()) 247 | _ -> assert false 248 249 let deprecatedPref name p = 250 combine_pspec @@ fun () -> 251 Util.warn ("Preference \"" ^ name ^ "\" is deprecated!\n" 252 ^ "It may be removed in the next release, so you should\n" 253 ^ "stop using this preference on the command line and\n" 254 ^ "in the profiles." 255 ^ (if read p <> readDefault p then "" else 256 "\nYou will not lose out on anything; you have currently\n" 257 ^ "set this preference to its default value.")) 258 259 let registerPref name typ cell pspec category cli_only deprec doc fulldoc = 260 if Util.StringMap.mem name !prefs then 261 raise (Util.Fatal ("Preference " ^ name ^ " registered twice")); 262 let pspec = 263 if not deprec then pspec 264 else deprecatedPref name cell pspec in 265 let pref = {category; doc; pspec; fulldoc; typ; cli_only; deprec} in 266 prefs := Util.StringMap.add name pref !prefs 267 268 let createPrefInternal name typ category cli_only local send default deprecated doc fulldoc printer parsefn m = 269 let m = Umarshal.(prod2 m (list string) id id) in 270 let newCell = rawPref default name in 271 registerPref name typ newCell (parsefn newCell) category cli_only deprecated doc fulldoc; 272 let (local, send) = 273 if not cli_only then (local, send) 274 else (true, Some (fun () -> false)) 275 in 276 adddumper name local 277 (fun () -> match send with None -> true | Some f -> f ()) 278 (function 279 | 0 -> Marshal.to_string (newCell.value, newCell.names) [] 280 | _ -> Umarshal.to_string m (newCell.value, newCell.names)); 281 addprinter name (fun () -> printer newCell.value); 282 addresetter 283 (fun () -> 284 newCell.setInProfile <- false; newCell.value <- newCell.defaultValue); 285 addloader name 286 (fun rpcVer s -> 287 if not cli_only then (* Better for compatibility to not fail if cli_only *) 288 let (value, names) = 289 match rpcVer with 290 | 0 -> Marshal.from_string s 0 291 | _ -> Umarshal.from_string m s 0 292 in 293 newCell.value <- value); 294 newCell 295 296 let create name ~category ?(cli_only=false) ?(local=false) ?send default ?(deprecated=false) doc fulldoc intern printer m = 297 createPrefInternal name `CUSTOM category cli_only local send default deprecated doc fulldoc printer 298 (fun cell -> Uarg.String (fun s -> set cell (intern (read cell) s))) 299 m 300 301 let createBool name ~category ?(cli_only=false) ?(local=false) ?send default ?(deprecated=false) doc fulldoc = 302 let doc = if default then doc ^ " (default true)" else doc in 303 createPrefInternal name `BOOL category cli_only local send default deprecated doc fulldoc 304 (fun v -> [if v then "true" else "false"]) 305 (fun cell -> Uarg.Bool (fun b -> set cell b)) 306 Umarshal.bool 307 308 let createInt name ~category ?(cli_only=false) ?(local=false) ?send default ?(deprecated=false) doc fulldoc = 309 createPrefInternal name `INT category cli_only local send default deprecated doc fulldoc 310 (fun v -> [string_of_int v]) 311 (fun cell -> Uarg.Int (fun i -> set cell i)) 312 Umarshal.int 313 314 let createString name ~category ?(cli_only=false) ?(local=false) ?send default ?(deprecated=false) doc fulldoc = 315 createPrefInternal name `STRING category cli_only local send default deprecated doc fulldoc 316 (fun v -> [v]) 317 (fun cell -> Uarg.String (fun s -> set cell s)) 318 Umarshal.string 319 320 let createStringList name ~category ?(cli_only=false) ?(local=false) ?send ?(deprecated=false) doc fulldoc = 321 createPrefInternal name `STRING_LIST category cli_only local send [] deprecated doc fulldoc 322 (fun v -> v) 323 (fun cell -> Uarg.String (fun s -> set cell (s:: read cell))) 324 Umarshal.(list string) 325 326 let createBoolWithDefault name ~category ?(cli_only=false) ?(local=false) ?send ?(deprecated=false) doc fulldoc = 327 createPrefInternal name `BOOLDEF category cli_only local send `Default deprecated doc fulldoc 328 (fun v -> [match v with 329 `True -> "true" 330 | `False -> "false" 331 | `Default -> "default"]) 332 (fun cell -> 333 Uarg.String 334 (fun s -> 335 let v = 336 match s with 337 "yes" | "true" -> `True 338 | "default" | "auto" -> `Default 339 | _ -> `False 340 in 341 set cell v)) 342 Umarshal.(sum3 unit unit unit 343 (function 344 | `True -> I31 () 345 | `False -> I32 () 346 | `Default -> I33 ()) 347 (function 348 | I31 () -> `True 349 | I32 () -> `False 350 | I33 () -> `Default)) 351 352 let markRemoved name = 353 addignored name 354 355 (*****************************************************************************) 356 (* Preferences file parsing *) 357 (*****************************************************************************) 358 359 let string2bool name = function 360 "true" -> true 361 | "false" -> false 362 | other -> raise (Util.Fatal (name^" expects a boolean value, but \n"^other 363 ^ " is not a boolean")) 364 365 let string2int name string = 366 try 367 int_of_string string 368 with Failure _ -> 369 raise (Util.Fatal (name ^ " expects an integer value, but\n" 370 ^ string ^ " is not an integer")) 371 372 (* Takes a filename and returns a list of "parsed lines" containing 373 (filename, lineno, varname, value) 374 in the same order as in the file. *) 375 let rec readAFile ?(fail=true) ?(add_ext=true) filename = 376 let path = profilePathname ~add_ext:add_ext filename in 377 let locname = 378 if add_ext then 379 Printf.sprintf "Profile \"%s\" (file \"%s\")" filename path 380 else 381 Printf.sprintf "File \"%s\"" path 382 in 383 let bom = "\xef\xbb\xbf" in (* BOM: UTF-8 byte-order mark *) 384 let rec loop chan lineNum lines = 385 match (try Some(input_line chan) with End_of_file -> None) with 386 None -> close_in chan; parseLines lines 387 | Some(theLine) -> 388 let theLine = 389 (* A lot of Windows tools start a UTF-8 encoded file by a 390 byte-order mark. We skip it. *) 391 if lines = [] && Util.startswith theLine bom then 392 String.sub theLine 3 (String.length theLine - 3) 393 else 394 theLine 395 in 396 loop chan (lineNum + 1) (((locname, lineNum), theLine) :: lines) 397 in 398 let chan = 399 try 400 profileFiles := (path, System.stat path) :: !profileFiles; 401 Some (System.open_in_bin path) 402 with Unix.Unix_error _ | Sys_error _ -> None 403 in 404 match chan, fail with 405 | None, true when add_ext -> 406 raise (Util.Fatal (Printf.sprintf 407 "Profile %s not found (looking for file %s)" filename path)) 408 | None, true -> 409 raise (Util.Fatal (Printf.sprintf 410 "Preference file %s not found" path)) 411 | None, false -> [] 412 | Some chan, _ -> 413 try loop chan 1 [] with e -> close_in_noerr chan; raise e 414 415 (* Takes a list of strings in reverse order and yields a list of "parsed lines" 416 in correct order *) 417 and parseLines lines = 418 let rec loop lines res = 419 match lines with 420 [] -> res 421 | (((locname, lineNum) as loc), theLine) :: rest -> 422 let theLine = Util.removeTrailingCR theLine in 423 let l = Util.trimWhitespace theLine in 424 let includes ~fail ~add_ext = 425 match Util.splitIntoWords theLine ' ' with 426 [_;f] -> 427 let sublines = 428 try 429 readAFile f ~fail:fail ~add_ext:add_ext 430 with Util.Fatal err -> 431 raise (Util.Fatal (Printf.sprintf 432 "Included from %s, line %d:\n%s" 433 (String.uncapitalize_ascii locname) lineNum err)) 434 in 435 loop rest (Safelist.append sublines res) 436 | _ -> raise (Util.Fatal(Printf.sprintf 437 "%s, line %d:\nGarbled 'include' directive: %s" 438 locname lineNum theLine)) in 439 if l = "" || l.[0]='#' then 440 loop rest res 441 else if Util.startswith theLine "include " then 442 includes ~fail:true ~add_ext:true 443 else if Util.startswith theLine "source " then 444 includes ~fail:true ~add_ext:false 445 else if Util.startswith theLine "include? " then 446 includes ~fail:false ~add_ext:true 447 else if Util.startswith theLine "source? " then 448 includes ~fail:false ~add_ext:false 449 else 450 match Util.splitAtChar theLine '=' with 451 i, Some j -> let (varName, theResult) = (fun f (i,j) -> (f i,f j)) 452 Util.trimWhitespace (i,j) in 453 loop rest ((loc, varName, theResult) :: res) 454 | _ -> (* theLine does not contain '=' *) 455 raise (Util.Fatal(Printf.sprintf 456 "%s, line %d:\nGarbled line (no '='): %s" 457 locname lineNum theLine)) in 458 loop lines [] 459 460 let processLines lines = 461 Safelist.iter 462 (fun ((locName, lineNum), varName, theResult) -> 463 try 464 let pref = Util.StringMap.find varName !prefs in 465 if pref.category = `Internal `Pseudo then raise Not_found; 466 if pref.cli_only then 467 raise (IllegalValue ("\"" ^ varName 468 ^ "\" is a command line-only option; " 469 ^ "it must not be present in a profile.")); 470 match pref.pspec with 471 Uarg.Bool boolFunction -> 472 boolFunction (string2bool varName theResult) 473 | Uarg.Int intFunction -> 474 intFunction (string2int varName theResult) 475 | Uarg.String stringFunction -> 476 stringFunction theResult 477 | _ -> assert false 478 with Not_found -> 479 raise (Util.Fatal (locName ^ ", line " ^ 480 string_of_int lineNum ^ ": `" ^ 481 varName ^ "' is not a valid option")) 482 | IllegalValue str -> 483 raise (Util.Fatal (locName ^ ", line " ^ 484 string_of_int lineNum ^ ": " ^ str))) 485 lines 486 487 let loadTheFile () = 488 match !profileName with 489 None -> () 490 | Some(n) -> processLines(readAFile n) 491 492 let loadStrings l = 493 let rec loop n out = function 494 | [] -> processLines (parseLines out) 495 | h :: t -> loop (n + 1) ((("<internal preferences>", n), h) :: out) t 496 in 497 loop 1 [] l 498 499 (*****************************************************************************) 500 (* Command-line parsing *) 501 (*****************************************************************************) 502 503 let _ = create "source" () 504 ~category:(`Advanced `General) 505 ~cli_only:true 506 "include a file's preferences" 507 "Include preferences from a file. \\texttt{source \\ARG{name}} reads the \ 508 file \\showtt{name} in the \\texttt{.unison} directory and includes its \ 509 contents as if it was part of a profile or given directly on command line." 510 (fun _ s -> processLines (readAFile ~add_ext:false s)) 511 (fun v -> []) Umarshal.unit 512 513 let _ = create "include" () 514 ~category:(`Advanced `General) 515 ~cli_only:true 516 "include a profile's preferences" 517 "Include preferences from a profile. \\texttt{include \\ARG{name}} reads \ 518 the profile \\showtt{name} (or file \\showtt{name} in the \\texttt{.unison} \ 519 directory if profile \\showtt{name} does not exist) and includes its \ 520 contents as if it was part of a profile or given directly on command line." 521 (fun _ s -> processLines (readAFile s)) 522 (fun v -> []) Umarshal.unit 523 524 let prefArg = function 525 Uarg.Bool(_) -> "" 526 | Uarg.Int(_) -> "n" 527 | Uarg.String(_) -> "xxx" 528 | _ -> assert false 529 530 (* Prepare a list of specs for [Uarg.parse] *) 531 let argspecs hook = 532 Util.StringMap.fold 533 (fun name pref l -> 534 if pref.category <> `Internal `Pseudo then 535 ("-" ^ name, hook name pref.pspec, "") :: l 536 else l) 537 !prefs [] 538 539 let title = function 540 | `Advanced `Sync -> "Fine-tune sync" 541 | `Advanced `General -> "Other" 542 | `Basic t | `Advanced t -> topic t 543 | `Expert -> "" 544 | `Internal _ -> assert false 545 let topic_title = title 546 547 let topicsInOrder = [ `Sync; `Syncprocess; `Syncprocess_CLI; `CLI; `GUI; `Remote; `Archive ] 548 549 let oneLineDocs ?(hpre="") ?(hpost="") u = 550 let buf = Buffer.create 1024 in 551 let out = Buffer.add_string buf in 552 let fmt = Format.formatter_of_buffer buf in 553 let () = Format.pp_set_margin fmt 81 in (* cols + 1 *) 554 555 let formatPref name {pspec; doc; deprec; _ } = 556 let arg = prefArg pspec in 557 let s = if arg = "" then name else name ^ " " ^ arg in 558 let l = max 1 (19 - String.length s) in 559 Format.pp_print_string fmt (" -" ^ s); 560 Format.pp_open_box fmt l; 561 Format.pp_print_break fmt l (1 - l); 562 if deprec then begin 563 Format.pp_print_string fmt "(deprecated)"; 564 Format.pp_print_space fmt () 565 end; 566 Format.pp_print_text fmt doc; 567 Format.pp_close_box fmt (); 568 Format.pp_print_newline fmt () 569 in 570 let formatTopic t = 571 let m = Util.StringMap.filter (fun _ pref -> pref.category = t) !prefs in 572 if Util.StringMap.cardinal m > 0 then begin 573 let h = title t in 574 if h <> "" then begin 575 out "\n"; out hpre; out " "; 576 out h; 577 out ":"; out hpost; out "\n" 578 end; 579 Util.StringMap.iter formatPref m 580 end 581 in 582 let formatTopics g = 583 Safelist.iter (fun t -> formatTopic (g t)) 584 in 585 586 out u; if u <> "" then out "\n"; 587 588 out (hpre ^ "Basic options:" ^ hpost ^ "\n"); 589 formatTopics (fun t -> `Basic t) (`General :: topicsInOrder); 590 591 out ("\n" ^ hpre ^ "Advanced options:" ^ hpost ^ "\n"); 592 formatTopics (fun t -> `Advanced t) (topicsInOrder @ [`General]); 593 594 out ("\n" ^ hpre ^ "Expert options:" ^ hpost ^ "\n"); 595 formatTopic (`Expert); 596 597 Buffer.contents buf 598 599 let printUsage usage = Uarg.usage (argspecs (fun _ s -> s)) 600 (oneLineDocs usage) 601 602 let printUsageForMan () = 603 print_string ".Bd -literal\n"; 604 print_string (oneLineDocs ~hpre:".Sy \"" ~hpost:"\"" ""); 605 print_string ".Ed\n" 606 607 let processCmdLine usage hook = 608 Uarg.current := 0; 609 let argspecs = argspecs hook in 610 let defaultanonfun _ = 611 print_string "Anonymous arguments not allowed\n"; 612 Uarg.usage argspecs (oneLineDocs usage); 613 exit 2 614 in 615 let anonfun = 616 try 617 let {pspec = p; _} = Util.StringMap.find "rest" !prefs in 618 match hook "rest" p with 619 Uarg.String stringFunction -> stringFunction 620 | _ -> defaultanonfun 621 with 622 Not_found -> defaultanonfun 623 in 624 try 625 Uarg.parse argspecs anonfun (oneLineDocs usage) 626 with IllegalValue str -> 627 raise (Util.Fatal str) 628 629 let parseCmdLine usage = 630 processCmdLine usage (fun _ sp -> sp) 631 632 (* Scan command line without actually setting any preferences; return a *) 633 (* string map associating a list of strings with each option appearing on *) 634 (* the command line. *) 635 let scanCmdLine usage = 636 let m = ref (Util.StringMap.empty : (string list) Util.StringMap.t) in 637 let insert name s = 638 let old = try Util.StringMap.find name !m with Not_found -> [] in 639 m := Util.StringMap.add name (s :: old) !m in 640 processCmdLine usage 641 (fun name p -> 642 match p with 643 Uarg.Bool _ -> Uarg.Bool (fun b -> insert name (string_of_bool b)) 644 | Uarg.Int _ -> Uarg.Int (fun i -> insert name (string_of_int i)) 645 | Uarg.String _ -> Uarg.String (fun s -> insert name s) 646 | _ -> assert false); 647 !m 648 649 (*****************************************************************************) 650 (* Printing *) 651 (*****************************************************************************) 652 653 let listVisiblePrefs () = 654 let l = 655 Util.StringMap.fold 656 (fun name ({category; _} as pref) l -> 657 if not (isInternal category) then begin 658 (name, pref) :: l 659 end else l) !prefs [] in 660 Safelist.stable_sort (fun (name1, _) (name2, _) -> compare name1 name2) l 661 662 let printFullTeXDocs () = 663 Printf.eprintf "\\begin{description}\n"; 664 Safelist.iter 665 (fun (name, {pspec; fulldoc; deprec; _}) -> 666 Printf.eprintf "\\item [{%s \\tt %s}]\n%s%s\n\n" 667 name (prefArg pspec) (if deprec then "{\\em (Deprecated)} " else "") fulldoc) 668 (listVisiblePrefs()); 669 Printf.eprintf "\\end{description}\n" 670 671 let printFullManDocs () = 672 (* The output mangling code is taken from uigtk2.ml with some modifications. 673 Performance is not critical here, it is only run during the build, 674 never by users. *) 675 let (>>>) x f = f x in 676 let emptylineRe = Str.regexp "\n\n+" in 677 let newlineRe = Str.regexp "\n *" in 678 let nodotRe = Str.regexp "^\\([^.\n]+\\)" in 679 let macroRe = Str.regexp "\\(\\.[ \n]*\\)\\([A-Z]\\)" in 680 let styleRe = Str.regexp "\\([^ ]?\\){\\\\\\([a-z]+\\) \\([^{}]*\\)}\\(\\([^ }][^ ]*\\)?\\)" in 681 let verbRe = Str.regexp "\\([^ ]?\\)\\\\verb|\\([^|]*\\)|\\(\\([^ }][^ ]*\\)?\\)" in 682 let argRe = Str.regexp "\\([^ ]?\\)\\\\ARG{\\([^{}]*\\)}\\([^ }]*\\)" in 683 let textttRe = Str.regexp "\\([^ ]?\\)\\\\texttt{\\([^{}]*\\)}\\(\\([^ }][^ ]*\\)?\\)" in 684 let showttRe = Str.regexp "\\([^ ]?\\)\\\\showtt{\\([^{}]*\\)}\\([^ }]*\\)" in 685 let emphRe = Str.regexp "\\([^ ]?\\)\\\\emph{\\([^{}]*\\)}\\([^ }]*\\)" in 686 let sectionRe = Str.regexp "\\\\sectionref{\\([^{}]*\\)}{\\([^{}]*\\)}" in 687 let emdash = Str.regexp_string "---" in 688 let parRe = Str.regexp "\\\\par *" in 689 let underRe = Str.regexp "\\\\_ *" in 690 let dollarRe = Str.regexp "\\\\\\$ *" in 691 let dquotRe = Str.regexp "\"" in 692 let nn1Re = Str.regexp "\\(\\( -NN-\\)+ -NN-\\|\\( -NN-\\)* -NS-\\)\\." in 693 let nn2Re = Str.regexp "\\( -NN-\\)+" in 694 let substMacro m s = 695 (match Str.matched_group 1 s with "" -> " -NN-." | s -> s ^ " -NS-.") ^ 696 m ^ 697 (Str.matched_group 2 s) ^ 698 (match Str.matched_group 3 s with "" -> "" | s -> " Ns " ^ s) ^ 699 " -NN-" 700 in 701 let tex2man doc = 702 doc >>> 703 Str.global_replace macroRe "\\1\\&\\2" >>> 704 Str.global_substitute styleRe 705 (fun s -> 706 try 707 let tag = 708 match Str.matched_group 2 s with 709 "em" -> ".Em" 710 | "tt" -> ".Sy" 711 | _ -> raise Exit 712 in 713 Printf.sprintf "%s%s %s%s -NN-" 714 (match Str.matched_group 1 s with "" -> " -NN-" | s -> s ^ " -NS-") 715 tag 716 (Str.matched_group 3 s) 717 (match Str.matched_group 4 s with "" -> "" | s -> " Ns " ^ s) 718 with Exit -> 719 Str.matched_group 0 s) >>> 720 Str.global_substitute verbRe (substMacro "Ic ") >>> 721 Str.global_substitute argRe (substMacro "Ar ") >>> 722 Str.global_substitute textttRe (substMacro "Sy ") >>> 723 Str.global_substitute showttRe (substMacro "Dq ") >>> 724 Str.global_substitute emphRe (substMacro "Em ") >>> 725 Str.global_replace sectionRe "Section\n.Dq \\2\n in the manual" >>> 726 Str.global_replace emdash "\xe2\x80\x94" >>> 727 Str.global_replace parRe "\n" >>> 728 Str.global_replace underRe "_" >>> 729 Str.global_replace dollarRe "$" >>> 730 Str.global_replace dquotRe "\\&\"" >>> 731 Str.global_replace nn1Re " Ns " >>> 732 Str.global_replace nn2Re "\n" >>> 733 Str.global_replace newlineRe "\n" >>> 734 Str.global_replace emptylineRe "\n" >>> 735 Str.global_replace nodotRe ".No \\1" >>> 736 Util.trimWhitespace 737 in 738 Printf.printf ".Bl -tag\n"; 739 Safelist.iter 740 (fun (name, {pspec; fulldoc; deprec; _}) -> 741 Printf.printf ".It Ic %s%s\n%s%s\n" 742 name 743 (match prefArg pspec with "" -> "" | s -> " Ar " ^ s) 744 (if deprec then ".Em ( Deprecated )\n" else "") 745 (tex2man fulldoc) 746 ) 747 (listVisiblePrefs()); 748 Printf.printf ".El\n" 749 750 let printFullDocs = function 751 | `TeX -> printFullTeXDocs () 752 | `man -> printFullManDocs () 753 754 (*****************************************************************************) 755 (* Adding stuff to the prefs file *) 756 (*****************************************************************************) 757 758 let addprefsto = createString "addprefsto" "" 759 ~category:(`Advanced `General) 760 "file to add new prefs to" 761 "By default, new preferences added by Unison (e.g., new \\verb|ignore| \ 762 clauses) will be appended to whatever preference file Unison was told \ 763 to load at the beginning of the run. Setting the preference \ 764 \\texttt{addprefsto \\ARG{filename}} makes Unison \ 765 add new preferences to the file named \\ARG{filename} instead." 766 767 let addLine l = 768 let filename = 769 if read addprefsto <> "" 770 then profilePathname (read addprefsto) 771 else thePrefsFile() in 772 try 773 debug (fun() -> 774 Util.msg "Adding '%s' to %s\n" l (System.fspathToDebugString filename)); 775 let resultmsg = 776 l ^ "' added to profile " ^ filename in 777 let ochan = 778 System.open_out_gen [Open_wronly; Open_creat; Open_append] 0o600 filename 779 in 780 output_string ochan "\n"; 781 output_string ochan l; 782 close_out ochan; 783 resultmsg 784 with 785 Sys_error e -> 786 begin 787 let resultmsg = 788 (Printf.sprintf "Could not write preferences file (%s)\n" e) in 789 Util.warn resultmsg; 790 resultmsg 791 end 792 793 let add name value = addLine (name ^ " = " ^ value) 794 795 let addComment c = ignore (addLine ("# " ^ c))