util.ml (18931B)
1 (* Unison file synchronizer: src/ubase/util.ml *) 2 (* Copyright 1999-2020, Benjamin C. Pierce 3 4 This program is free software: you can redistribute it and/or modify 5 it under the terms of the GNU General Public License as published by 6 the Free Software Foundation, either version 3 of the License, or 7 (at your option) any later version. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 GNU General Public License for more details. 13 14 You should have received a copy of the GNU General Public License 15 along with this program. If not, see <http://www.gnu.org/licenses/>. 16 *) 17 18 19 (*****************************************************************************) 20 (* CASE INSENSITIVE COMPARISON *) 21 (*****************************************************************************) 22 (* Latin1 (ISO 8859-1) string functions have been deprecated in OCaml. Latin1 23 being supported by Unison, the deprecated Stdlib has been replaced with 24 this lowercase_latin1 function. *) 25 let lowercase_latin1 = function 26 | 'A' .. 'Z' 27 | '\192' .. '\214' 28 | '\216' .. '\222' as c -> 29 Char.chr(Char.code c + 32) 30 | c -> c 31 32 let nocase_cmp a b = 33 let alen = String.length a in 34 let blen = String.length b in 35 let minlen = if alen<blen then alen else blen in 36 let rec loop i = 37 if i>=minlen then compare alen blen 38 else 39 let c = 40 compare (lowercase_latin1(String.get a i)) (lowercase_latin1(String.get b i)) in 41 if c<>0 then c else loop (i+1) in 42 loop 0 43 let nocase_eq a b = (0 = (nocase_cmp a b)) 44 45 46 (*****************************************************************************) 47 (* PRE-BUILT MAP AND SET MODULES *) 48 (*****************************************************************************) 49 50 module StringMap = Map.Make (String) 51 module StringSet = Set.Make (String) 52 53 let stringSetFromList l = 54 Safelist.fold_right StringSet.add l StringSet.empty 55 56 (*****************************************************************************) 57 (* Debugging / error messages *) 58 (*****************************************************************************) 59 60 type infos = { s : string; clr : string } 61 let infos = ref { s = ""; clr = "" } 62 63 let clear_infos () = 64 if !infos.clr <> "" then begin 65 print_string !infos.clr; 66 flush stdout 67 end else if !infos.s <> "" then begin 68 print_string "\r"; 69 print_string (String.make (String.length !infos.s) ' '); 70 print_string "\r"; 71 flush stdout 72 end 73 let show_infos () = 74 if !infos.s <> "" then begin print_string !infos.s; flush stdout end 75 let set_infos ?(clr = "") s = 76 if s <> !infos.s then begin clear_infos (); infos := {s; clr}; show_infos () end 77 78 let msg f = 79 clear_infos (); 80 Printf.kfprintf (fun _ -> flush stderr; show_infos ()) stderr f 81 82 let msg : ('a, out_channel, unit) format -> 'a = msg 83 84 (* ------------- Formatting stuff --------------- *) 85 86 let curr_formatter = ref Format.std_formatter 87 88 let format f = Format.fprintf (!curr_formatter) f 89 let format : ('a, Format.formatter, unit) format -> 'a = format 90 91 let format_to_string f = 92 let old_formatter = !curr_formatter in 93 curr_formatter := Format.str_formatter; 94 f (); 95 let s = Format.flush_str_formatter () in 96 curr_formatter := old_formatter; 97 s 98 99 let flush () = Format.pp_print_flush (!curr_formatter) () 100 101 (*****************************************************************************) 102 (* GLOBAL DEBUGGING SWITCH *) 103 (*****************************************************************************) 104 105 let debugPrinter = ref None 106 107 let debug s th = 108 match !debugPrinter with 109 None -> assert false 110 | Some p -> p s th 111 112 (* This should be set by the UI to a function that can be used to warn users *) 113 let warnPrinter = ref (Some (msg "Warning: %s")) 114 115 (* The rest of the program invokes this function to warn users. *) 116 let warn message = 117 match !warnPrinter with 118 None -> () 119 | Some p -> p message 120 121 (*****************************************************************************) 122 (* EXCEPTION HANDLING *) 123 (*****************************************************************************) 124 125 exception Fatal of string 126 exception Transient of string 127 128 let encodeException m kind e = 129 let reraise s = 130 match kind with 131 `Fatal -> raise (Fatal s) 132 | `Transient -> raise (Transient s) 133 in 134 let kindStr = 135 match kind with 136 `Fatal -> "Fatal" 137 | `Transient -> "Transient" 138 in 139 match e with 140 Unix.Unix_error(err,fnname,param) -> 141 let s = "Error in " ^ m ^ ":\n" 142 ^ (Unix.error_message err) 143 ^ " [" ^ fnname ^ "(" ^ param ^ ")]" ^ 144 (match err with 145 Unix.EUNKNOWNERR n -> Format.sprintf " (code %d)" n 146 | _ -> "") 147 in 148 debug "exn" 149 (fun() -> msg "Converting a Unix error to %s:\n%s\n" kindStr s); 150 reraise s 151 | Transient(s) -> 152 debug "exn" (fun() -> 153 if kind = `Fatal then 154 msg "In %s: Converting a Transient error to %s:\n%s\n" m kindStr s 155 else 156 msg "In %s: Propagating Transient error\n" m); 157 reraise s 158 | Not_found -> 159 let s = "Not_found raised in " ^ m 160 ^ " (this indicates a bug!)" in 161 debug "exn" 162 (fun() -> msg "Converting a Not_found to %s:\n%s\n" kindStr s); 163 reraise s 164 | Invalid_argument a -> 165 let s = "Invalid_argument("^a^") raised in " ^ m 166 ^ " (this indicates a bug!)" in 167 debug "exn" 168 (fun() -> msg "Converting an Invalid_argument to %s:\n%s\n" kindStr s); 169 reraise s 170 | Sys_error(s) -> 171 let s = "Error in " ^ m ^ ":\n" ^ s in 172 debug "exn" 173 (fun() -> msg "Converting a Sys_error to %s:\n%s\n" kindStr s); 174 reraise s 175 | Sys_blocked_io -> 176 let s = "Blocked IO error in " ^ m in 177 debug "exn" 178 (fun() -> msg "Converting a Sys_blocked_io to %s:\n%s\n" kindStr s); 179 reraise s 180 | _ -> 181 raise e 182 183 let convertUnixErrorsToExn m f n e = 184 try f() 185 with 186 Unix.Unix_error(err,fnname,param) -> 187 let s = "Error in " ^ m ^ ":\n" 188 ^ (Unix.error_message err) 189 ^ " [" ^ fnname ^ "(" ^ param ^ ")]" in 190 debug "exn" 191 (fun() -> msg "Converting a Unix error to %s:\n%s\n" n s); 192 raise (e s) 193 | Transient(s) -> 194 debug "exn" (fun() -> 195 if n="Fatal" then 196 msg "In %s: Converting a Transient error to %s:\n%s\n" m n s 197 else 198 msg "In %s: Propagating Transient error\n" m); 199 raise (e s) 200 | Not_found -> 201 let s = "Not_found raised in " ^ m 202 ^ " (this indicates a bug!)" in 203 debug "exn" (fun() -> msg "Converting a Not_found to %s:\n%s\n" n s); 204 raise (e s) 205 | End_of_file -> 206 let s = "End_of_file exception raised in " ^ m 207 ^ " (this indicates a bug!)" in 208 debug "exn" (fun() -> msg "Converting an End_of_file to %s:\n%s\n" n s); 209 raise (e s) 210 | Sys_error(s) -> 211 let s = "Error in " ^ m ^ ":\n" ^ s in 212 debug "exn" (fun() -> msg "Converting a Sys_error to %s:\n%s\n" n s); 213 raise (e s) 214 | Sys_blocked_io -> 215 let s = "Blocked IO error in " ^ m in 216 debug "exn" (fun() -> msg "Converting a Sys_blocked_io to %s:\n%s\n" 217 n s); 218 raise (e s) 219 220 let convertUnixErrorsToFatal m f = 221 convertUnixErrorsToExn m f "Fatal" (fun str -> Fatal(str)) 222 223 let convertUnixErrorsToTransient m f = 224 convertUnixErrorsToExn m f "Transient" (fun str -> Transient(str)) 225 226 let unwindProtect f cleanup = 227 try 228 f () 229 with 230 Transient _ as e -> 231 debug "exn" (fun () -> msg "Exception caught by unwindProtect\n"); 232 convertUnixErrorsToFatal "unwindProtect" (fun()-> cleanup e); 233 raise e 234 235 let finalize f cleanup = 236 try 237 let res = f () in 238 cleanup (); 239 res 240 with 241 Transient _ as e -> 242 debug "exn" (fun () -> msg "Exception caught by finalize\n"); 243 convertUnixErrorsToFatal "finalize" cleanup; 244 raise e 245 246 type confirmation = 247 Succeeded 248 | Failed of string 249 250 let ignoreTransientErrors thunk = 251 try 252 thunk() 253 with 254 Transient(s) -> () 255 256 let printException e = 257 try 258 raise e 259 with 260 Transient s -> s 261 | Fatal s -> s 262 | e -> Printexc.to_string e 263 264 (* Safe version of Unix getenv -- raises a comprehensible error message if 265 called with an env variable that doesn't exist *) 266 let safeGetenv var = 267 convertUnixErrorsToFatal 268 "querying environment" 269 (fun () -> 270 try System.getenv var 271 with Not_found -> 272 raise (Fatal ("Environment variable " ^ var ^ " not found"))) 273 274 let process_status_to_string = function 275 Unix.WEXITED i -> Printf.sprintf "Exited with status %d" i 276 | Unix.WSIGNALED i -> Printf.sprintf "Killed by signal %d" i 277 | Unix.WSTOPPED i -> Printf.sprintf "Stopped by signal %d" i 278 279 280 let blockSignals sigs f = 281 let (prevMask, ok) = 282 try (Unix.sigprocmask SIG_BLOCK sigs, true) 283 with Invalid_argument _ -> ([], false) in 284 let restoreMask () = 285 if ok then Unix.sigprocmask SIG_SETMASK prevMask |> ignore in 286 try let r = f () in restoreMask (); r 287 with e -> 288 let origbt = Printexc.get_raw_backtrace () in 289 restoreMask (); 290 Printexc.raise_with_backtrace e origbt 291 292 (*****************************************************************************) 293 (* MISCELLANEOUS *) 294 (*****************************************************************************) 295 296 let monthname n = 297 Safelist.nth 298 ["Jan";"Feb";"Mar";"Apr";"May";"Jun";"Jul";"Aug";"Sep";"Oct";"Nov";"Dec"] 299 n 300 301 let localtime f = 302 convertUnixErrorsToTransient "localtime" (fun()-> Unix.localtime f) 303 304 let time () = 305 convertUnixErrorsToTransient "time" Unix.time 306 307 let time2string timef = 308 try 309 let time = localtime timef in 310 (* Old-style: 311 Printf.sprintf 312 "%2d:%.2d:%.2d on %2d %3s, %4d" 313 time.Unix.tm_hour 314 time.Unix.tm_min 315 time.Unix.tm_sec 316 time.Unix.tm_mday 317 (monthname time.Unix.tm_mon) 318 (time.Unix.tm_year + 1900) 319 *) 320 Printf.sprintf 321 "%4d-%02d-%02d at %2d:%.2d:%.2d" 322 (time.Unix.tm_year + 1900) 323 (time.Unix.tm_mon + 1) 324 time.Unix.tm_mday 325 time.Unix.tm_hour 326 time.Unix.tm_min 327 time.Unix.tm_sec 328 with Transient _ -> 329 "(invalid date)" 330 331 let percentageOfTotal current total = 332 (int_of_float ((float current) *. 100.0 /. (float total))) 333 334 let percent2string p = Printf.sprintf "%3d%%" (truncate (max 0. (min 100. p))) 335 336 let gib = 1073741824. 337 let mib = 1048576. 338 let kib = 1024. 339 let bytes2string v = 340 if v > 1_048_051_711L then 341 Printf.sprintf "%.2f GiB" (Int64.to_float v /. gib) 342 else if v > 104_805_171L then 343 Printf.sprintf "%.0f MiB" (Int64.to_float v /. mib) 344 else if v > 1_023_487L then 345 Printf.sprintf "%.1f MiB" (Int64.to_float v /. mib) 346 else if v > 102_348L then 347 Printf.sprintf "%.0f KiB" (Int64.to_float v /. kib) 348 else if v > 999L then 349 Printf.sprintf "%.1f KiB" (Int64.to_float v /. kib) 350 else 351 Printf.sprintf "%Ld B" v 352 353 let extractValueFromOption = function 354 None -> raise (Fatal "extractValueFromOption failed") 355 | Some(v) -> v 356 357 let option2string (prt: 'a -> string) = function 358 Some x -> prt x 359 | None -> "N.A." 360 361 (*****************************************************************************) 362 (* String utility functions *) 363 (*****************************************************************************) 364 365 let truncateString s count = 366 (* Truncate a string by counting code points instead of bytes. *) 367 let rec subValidUTF8 ?(extra = 0) s pos len = 368 (* Like [String.sub] but tries to keep the substring a valid UTF-8 369 string (it may not be meaningful in any way but the encoding is not 370 broken). Requires the input string to be valid UTF-8 to work 371 properly. 372 If the initial substring (like a simple [String.sub]) is not valid 373 UTF-8 then it tries to blindly extend (never reduce) the substring 374 until it becomes valid UTF-8. This is a very simple implementation 375 that works without knowing anything about the UTF-8 encoding. *) 376 let totl = String.length s in 377 if pos >= totl then 378 None 379 else if pos + len > totl then 380 Some (String.sub s pos (totl - pos)) 381 else 382 let s' = String.sub s pos len in 383 if Unicode.check_utf_8 s' || extra > 5 then 384 Some s' 385 else 386 subValidUTF8 s pos (len + 1) ~extra:(extra + 1) 387 in 388 let rec extractCodepoints pos count s' s = 389 (* Somewhat like [String.sub] but instead of number of bytes, extracts 390 [count] number of code points from the string while [pos] is still 391 counted in bytes. *) 392 match subValidUTF8 s pos 1 with 393 | None -> s' 394 | Some s'' -> 395 if count > 1 then 396 extractCodepoints (pos + String.length s'') (count - 1) (s' ^ s'') s 397 else s' ^ s'' 398 in 399 let s = Unicode.compose (Unicode.protect s) in 400 let s' = extractCodepoints 0 (count - 3) "" s in 401 let s'' = extractCodepoints (String.length s') 3 "" s in 402 if String.length s' + String.length s'' < String.length s then 403 s' ^ "..." 404 else 405 s' ^ s'' 406 407 let findsubstring ?reverse:(rev=false) s1 s2 = 408 let l1 = String.length s1 in 409 let l2 = String.length s2 in 410 let rec loop i = 411 if i+l1 > l2 || i < 0 then None 412 else if s1 = String.sub s2 i l1 then Some(i) 413 else loop (if rev then i-1 else i+1) 414 in loop (if rev then l2-l1 else 0) 415 416 let rec replacesubstring s fromstring tostring = 417 match findsubstring fromstring s with 418 None -> s 419 | Some(i) -> 420 let before = String.sub s 0 i in 421 let afterpos = i + (String.length fromstring) in 422 let after = String.sub s afterpos ((String.length s) - afterpos) in 423 before ^ tostring ^ (replacesubstring after fromstring tostring) 424 425 let replacesubstrings s pairs = 426 Safelist.fold_left 427 (fun s' (froms,tos) -> replacesubstring s' froms tos) 428 s pairs 429 430 let startswith s1 s2 = 431 let l1 = String.length s1 in 432 let l2 = String.length s2 in 433 if l1 < l2 then false else 434 let rec loop i = 435 if i>=l2 then true 436 else if s1.[i] <> s2.[i] then false 437 else loop (i+1) 438 in loop 0 439 440 let endswith s1 s2 = 441 let l1 = String.length s1 in 442 let l2 = String.length s2 in 443 let offset = l1 - l2 in 444 if l1 < l2 then false else 445 let rec loop i = 446 if i>=l2 then true 447 else if s1.[i+offset] <> s2.[i] then false 448 else loop (i+1) 449 in loop 0 450 451 let concatmap sep f l = 452 String.concat sep (Safelist.map f l) 453 454 let removeTrailingCR s = 455 let l = String.length s in 456 if l = 0 || s.[l - 1] <> '\r' then s else 457 String.sub s 0 (l - 1) 458 459 let trimWhitespace s = 460 let l = String.length s in 461 let rec loop lp rp = 462 if lp > rp then "" 463 else if s.[lp]=' ' || s.[lp]='\t' || s.[lp]='\n' || s.[lp]='\r' then 464 loop (lp+1) rp 465 else if s.[rp]=' ' || s.[rp]='\t' || s.[rp]='\n' || s.[rp]='\r' then 466 loop lp (rp-1) 467 else 468 String.sub s lp (rp+1-lp) 469 in 470 loop 0 (l-1) 471 472 let splitAtChar ?reverse:(rev=false) (s:string) (c:char) = 473 try 474 let i = if rev then String.rindex s c else String.index s c 475 and l = String.length s in 476 (* rest is possibly the empty string *) 477 (String.sub s 0 i, Some (String.sub s (i+1) (l-i-1))) 478 with Not_found -> (s, None) 479 480 let splitIntoWords ?esc:(e='\\') (s:string) (c:char) = 481 let rec inword acc eacc start pos = 482 if pos >= String.length s || s.[pos] = c then 483 let word = 484 String.concat "" (Safelist.rev (String.sub s start (pos-start)::eacc)) in 485 betweenwords (word::acc) pos 486 else if s.[pos] = e then inescape acc eacc start pos 487 else inword acc eacc start (pos+1) 488 and inescape acc eacc start pos = 489 let eword = String.sub s start (pos-start) in 490 if pos+1 >= String.length s 491 then inword acc (eword::eacc) (pos+1) (pos+1) (* ignore final esc *) 492 else (* take any following char *) 493 let echar = String.make 1 (String.get s (pos+1)) in 494 inword acc (echar::eword::eacc) (pos+2) (pos+2) 495 and betweenwords acc pos = 496 if pos >= String.length s then (Safelist.rev acc) 497 else if s.[pos]=c then betweenwords acc (pos+1) 498 else inword acc [] pos pos 499 in betweenwords [] 0 500 501 let splitAtString ?(reverse=false) s sep = 502 match findsubstring ~reverse:reverse sep s with 503 None -> (s, None) 504 | Some(i) -> 505 let before = String.sub s 0 i in 506 let afterpos = i + (String.length sep) in 507 let after = String.sub s afterpos ((String.length s) - afterpos) in 508 (* rest is possibly the empty string *) 509 (before, Some after) 510 511 let rec splitIntoWordsByString s sep = 512 match splitAtString s sep with 513 (s, None) -> [s] 514 | (before, Some after) -> before :: (splitIntoWordsByString after sep) 515 516 let padto n s = s ^ (String.make (max 0 (n - String.length s)) ' ') 517 518 (*****************************************************************************) 519 (* Building pathnames in the user's home dir *) 520 (*****************************************************************************) 521 522 let homeDir () = 523 (if Sys.unix || Sys.cygwin then 524 safeGetenv "HOME" 525 else if Sys.win32 then 526 (*We don't want the behavior of Unison to depends on whether it is run 527 from a Cygwin shell (where HOME is set) or in any other way (where 528 HOME is usually not set) 529 try System.getenv "HOME" (* Windows 9x with Cygwin HOME set *) 530 with Not_found -> 531 *) 532 try System.getenv "USERPROFILE" (* Windows NT/2K standard *) 533 with Not_found -> 534 try System.getenv "UNISON" 535 (* Use custom UNISON dir if it is set. This can be a path 536 or just the name of the folder you want to use in the 537 current directory *) 538 with Not_found -> 539 "c:/" (* Default *) 540 else 541 assert false (* osType can't be anything else *)) 542 543 let fileInHomeDir n = Filename.concat (homeDir ()) n 544 545 (*****************************************************************************) 546 (* .unison dir *) 547 (*****************************************************************************) 548 549 external isMacOSXPred : unit -> bool = "isMacOSX" 550 551 let isMacOSX = isMacOSXPred () 552 553 let unisonDir = 554 try 555 System.getenv "UNISON" 556 with Not_found -> 557 let genericName = 558 fileInHomeDir (Printf.sprintf ".%s" ProjectInfo.myName) in 559 if isMacOSX && not (System.file_exists genericName) then 560 fileInHomeDir "Library/Application Support/Unison" 561 else 562 genericName 563 564 let fileInUnisonDir str = Filename.concat unisonDir str 565 566 let fileMaybeRelToUnisonDir n = 567 if Filename.is_relative n 568 then fileInUnisonDir n 569 else n