system_generic.ml (5217B)
1 (* Unison file synchronizer: src/system/system_generic.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 type fspath = string 19 20 let mfspath = Umarshal.string 21 22 let extendedPath f = f 23 24 let fspathToDebugString f = String.escaped f 25 26 (****) 27 28 let getenv = Sys.getenv 29 let putenv = Unix.putenv 30 let argv () = Sys.argv 31 32 (****) 33 34 type dir_handle = { readdir : unit -> string; closedir : unit -> unit } 35 36 let stat = Unix.LargeFile.stat 37 let lstat = Unix.LargeFile.lstat 38 let rmdir = Unix.rmdir 39 let mkdir = Unix.mkdir 40 let unlink = Unix.unlink 41 let rename = Unix.rename 42 let open_in_gen = open_in_gen 43 let open_out_gen = open_out_gen 44 let chmod = Unix.chmod 45 let chown = Unix.chown 46 let utimes = Unix.utimes 47 let link s d = Unix.link s d 48 let openfile = Unix.openfile 49 let opendir f = 50 let h = Unix.opendir f in 51 { readdir = (fun () -> Unix.readdir h); 52 closedir = (fun () -> Unix.closedir h) } 53 54 let readdir = Unix.readdir 55 let closedir = Unix.closedir 56 let readlink = Unix.readlink 57 (* BCP 5/16: Eta-expand for backward compatibility with OCaml <=4.02 *) 58 let symlink s1 s2 = Unix.symlink s1 s2 59 let chdir = Sys.chdir 60 let getcwd = Sys.getcwd 61 62 (****) 63 64 let file_exists = Sys.file_exists 65 let open_in_bin = open_in_bin 66 67 (****) 68 69 external clone_path : string -> string -> bool = "unison_clone_path" 70 external clone_file : Unix.file_descr -> Unix.file_descr -> bool = 71 "unison_clone_file" 72 external copy_file : Unix.file_descr -> Unix.file_descr -> int64 73 -> int -> int = "unison_copy_file" 74 75 (****) 76 77 let create_process = Unix.create_process 78 let open_process_in = Unix.open_process_in 79 let open_process_args_in = Unix.open_process_args_in 80 let open_process_out = Unix.open_process_out 81 let open_process_full cmd = Unix.open_process_full cmd (Unix.environment ()) 82 let open_process_args_full cmd args = Unix.open_process_args_full cmd args (Unix.environment ()) 83 let process_in_pid = Unix.process_in_pid 84 let process_out_pid = Unix.process_out_pid 85 let process_full_pid = Unix.process_full_pid 86 let close_process_in = Unix.close_process_in 87 let close_process_out = Unix.close_process_out 88 let close_process_full = Unix.close_process_full 89 90 (****) 91 92 let isNotWindows = not Sys.win32 93 94 (* Note that Cygwin provides some kind of inode numbers, but we only 95 have access to the lower 32 bits on 32bit systems... *) 96 (* Best effort inode numbers are provided in Windows since OCaml 4.03 *) 97 (* However, these inode numbers are not usable on FAT filesystems, as 98 renaming a file "b" over a file "a" does not change the inode 99 number of "a". *) 100 let hasInodeNumbers () = true 101 102 let hasSymlink = Unix.has_symlink 103 104 (* Cygwin can apparently provide correct ctime. 105 * 106 * With current OCaml Unix library, ctime is not correct on Win32. 107 * This can change in future, in which case [hasCorrectCTime] should 108 * be made dependent on OCaml version. *) 109 let hasCorrectCTime = isNotWindows 110 111 (****) 112 113 type terminalStateFunctions = 114 { defaultTerminal : unit -> unit; rawTerminal : unit -> unit; 115 startReading : unit -> unit; stopReading : unit -> unit } 116 117 let terminalStateFunctions () = 118 let oldState = Unix.tcgetattr Unix.stdin in 119 { defaultTerminal = 120 (fun () -> Unix.tcsetattr Unix.stdin Unix.TCSANOW oldState); 121 rawTerminal = 122 (fun () -> 123 let newState = 124 { oldState with Unix.c_icanon = false; Unix.c_echo = false; 125 Unix.c_vmin = 1 } 126 in 127 Unix.tcsetattr Unix.stdin Unix.TCSANOW newState); 128 startReading = (fun () -> ()); 129 stopReading = (fun () -> ()) } 130 131 let termVtCapable fd = Unix.isatty fd 132 133 let has_stdout ~info:_ = true 134 let has_stderr ~info:_ = true 135 136 (****) 137 138 exception XattrNotSupported 139 let _ = Callback.register_exception "XattrNotSupported" XattrNotSupported 140 141 external xattr_list : string -> (string * int) list = "unison_xattrs_list" 142 external xattr_get_ : string -> string -> string = "unison_xattr_get" 143 external xattr_set_ : string -> string -> string -> unit = "unison_xattr_set" 144 external xattr_remove_ : string -> string -> unit = "unison_xattr_remove" 145 external xattr_updates_ctime : unit -> bool = "unison_xattr_updates_ctime" 146 147 let xattrUpdatesCTime = xattr_updates_ctime () 148 149 let xattr_get p n = 150 try xattr_get_ p n with 151 | Failure e -> failwith ("(attr: " ^ n ^ ") " ^ e) 152 153 let xattr_set p n v = 154 try xattr_set_ p n v with 155 | Failure e -> failwith ("(attr: " ^ n ^ ") " ^ e) 156 157 let xattr_remove p n = 158 try xattr_remove_ p n with 159 | Failure e -> failwith ("(attr: " ^ n ^ ") " ^ e) 160 161 (****) 162 163 external acl_get_text : string -> string = "unison_acl_to_text" 164 external acl_set_text : string -> string -> unit = "unison_acl_from_text"