system_win.ml (8889B)
1 (* Unison file synchronizer: src/system/system_win.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 (*XXXX 19 20 - Use SetConsoleOutputCP/SetConsoleCP in text mode ??? 21 http://www.codeproject.com/KB/cpp/unicode_console_output.aspx?display=Print 22 23 *) 24 25 include System_generic 26 27 (****) 28 29 let fixPath f = String.map (function '/' -> '\\' | c -> c) f 30 let winRootRx = Rx.rx "[a-zA-Z]:[/\\].*" 31 let winUncRx = Rx.rx "[/\\][/\\][^?/\\]+[/\\][^/\\]+[/\\].*" 32 let winFileNsPathRx = Rx.rx "//[?]/.+" 33 let extendedPath f = 34 if Rx.match_string winRootRx f then 35 fixPath ("\\\\?\\" ^ f) 36 else if Rx.match_string winUncRx f then 37 fixPath ("\\\\?\\UNC" ^ String.sub f 1 (String.length f - 1)) 38 else if Rx.match_string winFileNsPathRx f then 39 fixPath f 40 else 41 f 42 43 (****) 44 45 let sys_error e = 46 match e with 47 Unix.Unix_error (err, _, "") -> 48 raise (Sys_error (Unix.error_message err)) 49 | Unix.Unix_error (err, _, s) -> 50 raise (Sys_error (Format.sprintf "%s: %s" s (Unix.error_message err))) 51 | _ -> 52 raise e 53 54 (****) 55 56 external stat_impl : string -> bool -> Unix.LargeFile.stats = "win_stat" 57 let stat f = stat_impl f false 58 let lstat f = stat_impl f true 59 60 let rename f1 f2 = 61 (* Comment from original C stub implementation: 62 Windows Unicode API: when a file cannot be renamed due to a sharing 63 violation error or an access denied error, retry for up to 1 second, 64 in case the file is temporarily opened by an indexer or an anti-virus. *) 65 let rec ren_aux delay = 66 try 67 Unix.rename f1 f2 68 with 69 | (Unix.Unix_error ((Unix.EACCES | Unix.EUNKNOWNERR (-32)), _, _)) as e -> 70 (* ERROR_SHARING_VIOLATION *) 71 if (delay < 1.) then begin 72 Unix.sleepf delay; 73 ren_aux (delay *. 2.) 74 end else 75 raise e 76 | e -> raise e 77 in 78 ren_aux 0.01 79 80 let chown _ _ _ = raise (Unix.Unix_error (Unix.ENOSYS, "chown", "")) 81 82 (* TODO: O_APPEND in [Unix.openfile] for Windows was fixed in OCaml 5.3. 83 Remove the entire [openfile] definition below once the minimum supported 84 compiler version is >= 5.3. 85 Note: at the time of adding this comment, there is actually no code calling 86 [openfile] with O_APPEND. *) 87 let openfile f flags perm = 88 let fd = Unix.openfile f flags perm in 89 (* Comment from original C stub implementation: 90 Windows: implement somewhat the O_APPEND flag, so that appending 91 lines to a profile (ignored files, for instance) works instead of 92 overwriting the beginning of the file (the file pointer is moved to 93 the end when the file is opened, rather that each time something is 94 written, which is good enough here) *) 95 if List.mem Unix.O_APPEND flags then 96 ignore (Unix.LargeFile.lseek fd 0L Unix.SEEK_END); 97 fd 98 99 let readlink f = 100 (* Windows apparently mangles the link values if the value is an absolute 101 path. With [readlink] you're not getting back the same value you set 102 with [symlink] (except if it was a relative path). It's not clear if 103 this happens always or under certain circumstances only. 104 105 It's unclear how this mangling works, but it appears to convert the link 106 value to an NT namespace path under the \?? directory (with \DosDevices 107 being a symlink to it?). For regular DOS paths with a drive letter, this 108 is usually ok in terms of nearly-preserving the original link value, as it 109 only adds the \??\ prefix. For \\server\share\ network paths, it changes 110 the prefix to \??\UNC\server\share\. 111 112 https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/introduction-to-ms-dos-device-names 113 https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/object-directories 114 https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/object-names 115 116 This conversion happens to all(?) absolute paths to targets, whether they 117 were originally in the common DOS format, UNC, or already in Win32 file 118 namespace format (with \\?\ prefix). 119 120 Since we don't know what was the link value set by [symlink], we do as 121 little modification as possible to the output of [readlink]. This means 122 changing the prefix to \\?\ (because that's at least somewhat known to 123 user-space and something we can deal with) and hoping that the resulting 124 path is correct. Without this change the path will be rejected by some 125 (all?) filesystem syscalls. *) 126 let l = Unix.readlink f in 127 let len = String.length l in 128 if len > 3 && l.[0] = '\\' && l.[1] = '?' && l.[2] = '?' && l.[3] = '\\' then 129 "\\\\?\\" ^ (String.sub l 4 (len - 4)) 130 else l 131 132 external long_name : string -> string = "win_long_path_name" 133 let getcwd () = 134 try 135 (* Normalize the path *) 136 let s = long_name (Sys.getcwd ()) in 137 (* Convert the drive letter to uppercase *) 138 match s.[0] with 139 | 'a' .. 'z' -> String.capitalize_ascii s 140 | _ -> s 141 with e -> sys_error e 142 143 let badFileRx = Rx.rx ".*[?*].*" 144 let winFileNsPathRx = Rx.rx "[/\\][/\\][?][/\\].+" 145 146 let opendir d = 147 (* Windows uses wildcards to retrieve the list of files in a directory. 148 It is not possible to list files in a directory when the path name 149 itself contains the wildcards "*" or "?". *) 150 let d' = if Rx.match_string winFileNsPathRx d then String.sub d 4 (String.length d - 4) else d in 151 if Rx.match_string badFileRx d' then 152 raise (Unix.Unix_error (Unix.ENOENT, "opendir", d)); 153 System_generic.opendir d 154 155 (****) 156 157 external hasCorrectCTime_impl : unit -> bool = "win_has_correct_ctime" 158 159 let hasCorrectCTime = hasCorrectCTime_impl () 160 161 (****) 162 163 type fdopt = Unix.file_descr option 164 external initConsole : unit -> fdopt * fdopt * fdopt = "win_init_console" 165 external getConsoleMode : unit -> int = "win_get_console_mode" 166 external setConsoleMode : int -> unit = "win_set_console_mode" 167 external getConsoleOutputCP : unit -> int = "win_get_console_output_cp" 168 external setConsoleOutputCP : int -> unit = "win_set_console_output_cp" 169 170 external termVtCapable : Unix.file_descr -> bool = "win_vt_capable" 171 (* [termVtCapable] is for _output_ file descriptors. *) 172 173 let terminalStateFunctions () = 174 (* First, allocate a console in case we don't already have one. 175 Unix.stdin/out/err have bogus handles if they weren't redirected by 176 the user and there was no console at startup. We must restore them 177 if a console was allocated. The fd numbers for the handles are 178 hardcoded as 0, 1, 2, and must be redirected as well because these 179 fds are not restored automatically by Windows. The stdin/out/err 180 channels in Stdlib do not need to be restored separately because 181 they operate by same hardcoded fd numbers, which will be restored 182 when Unix.stdin/out/err are restored.*) 183 let redirect (in', out', err') = 184 let safe_redirect fd1' fd2 = 185 match fd1' with Some fd1 -> Unix.dup2 fd1 fd2 | None -> () 186 in 187 safe_redirect in' Unix.stdin; 188 safe_redirect out' Unix.stdout; 189 safe_redirect err' Unix.stderr 190 (* in', out', err' must not be closed after dup2 because they are set as 191 the std handles in Win32 API and something might break when they are 192 closed (in fact, most everything that does not use hardcoded fd numbers 193 0, 1, 2, which are the ones restored by these redirections). *) 194 in 195 let () = redirect (initConsole ()) in 196 let oldstate = getConsoleMode () in 197 let oldcp = getConsoleOutputCP () in 198 (* 0x200 = ENABLE_VIRTUAL_TERMINAL_INPUT *) 199 let vtin = if termVtCapable Unix.stdout then 0x200 else 0x0 in 200 (* Ctrl-C does not interrupt a call to ReadFile when 201 ENABLE_LINE_INPUT is not set, so we handle Ctr-C 202 as a character when reading from the console. 203 We still want Ctrl-C to generate an exception when not reading 204 from the console in order to be able to interrupt Unison at any 205 time. *) 206 { defaultTerminal = (fun () -> setConsoleMode oldstate; 207 setConsoleOutputCP oldcp); 208 rawTerminal = (fun () -> setConsoleMode 0x19; setConsoleOutputCP 65001); 209 startReading = (fun () -> setConsoleMode (0x18 lor vtin)); 210 stopReading = (fun () -> setConsoleMode 0x19) } 211 212 external has_stdout : info:string -> bool = "win_hasconsole_gui_stdout" 213 external has_stderr : info:string -> bool = "win_hasconsole_gui_stderr"