diff --git a/src/core/opamConsole.ml b/src/core/opamConsole.ml index 6dbe688ce71..a0479d56cee 100644 --- a/src/core/opamConsole.ml +++ b/src/core/opamConsole.ml @@ -233,12 +233,22 @@ let acolor c () = colorise c let acolor_w width c oc s = output_string oc (acolor_with_width (Some width) c () s) -type win32_color_mode = Shim | VT100 +type win32_color_mode = Shim | VT100 of (unit -> unit) type _ shim_return = | Handle : (OpamStubs.handle * win32_color_mode) shim_return | Mode : win32_color_mode shim_return - | Peek : (win32_color_mode -> bool) shim_return + | Peek : bool shim_return + +let force_win32_vt100 h () = + let hConsoleOutput = + OpamStubs.getStdHandle h + in + let mode = OpamStubs.getConsoleMode hConsoleOutput in + (* ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x4 *) + let vt100_on = 0x4 in + if mode land vt100_on = 0 then + OpamStubs.setConsoleMode hConsoleOutput (mode lor vt100_on) |> ignore let enable_win32_vt100 ch = let hConsoleOutput = @@ -249,7 +259,7 @@ let enable_win32_vt100 ch = (* ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x4 *) let vt100_on = 0x4 in if mode land vt100_on <> 0 then - (hConsoleOutput, VT100) + (hConsoleOutput, VT100(force_win32_vt100 ch)) else if OpamStubs.setConsoleMode hConsoleOutput (mode lor vt100_on) then begin let restore_console () = @@ -259,29 +269,31 @@ let enable_win32_vt100 ch = OpamStubs.setConsoleMode hConsoleOutput mode |> ignore in at_exit restore_console; - (hConsoleOutput, VT100) + (hConsoleOutput, VT100(force_win32_vt100 ch)) end else (hConsoleOutput, Shim) with Not_found -> - (hConsoleOutput, VT100) + (hConsoleOutput, VT100(force_win32_vt100 ch)) let stdout_state = lazy (enable_win32_vt100 OpamStubs.STD_OUTPUT_HANDLE) let stderr_state = lazy (enable_win32_vt100 OpamStubs.STD_ERROR_HANDLE) let get_win32_console_shim : type s . [ `stdout | `stderr ] -> s shim_return -> s = fun ch -> - let ch = if ch = `stdout then stdout_state else stderr_state in + let (h, ch) = if ch = `stdout then (OpamStubs.STD_OUTPUT_HANDLE, stdout_state) else (OpamStubs.STD_ERROR_HANDLE, stderr_state) in function | Handle -> Lazy.force ch | Mode -> Lazy.force ch |> snd | Peek -> - fun mode -> - if Lazy.is_val ch then - snd (Lazy.force ch) = mode - else - false + if Lazy.is_val ch then + let r = (snd (Lazy.force ch) <> Shim) in + if r then + force_win32_vt100 h (); + r + else + false (* * Layout of attributes (wincon.h) @@ -313,14 +325,16 @@ let win32_print_message ch msg = | `stdout -> stdout | `stderr -> stderr in - if get_win32_console_shim ch Peek VT100 then + if get_win32_console_shim ch Peek then Printf.fprintf ocaml_ch "%s%!" msg else let (hConsoleOutput, mode) = get_win32_console_shim ch Handle in - if mode = VT100 then begin + match mode with + | VT100 force -> + force (); output_string ocaml_ch msg; flush ocaml_ch - end else + | Shim -> let {OpamStubs.attributes; _} = OpamStubs.getConsoleScreenBufferInfo hConsoleOutput in @@ -426,7 +440,8 @@ let carriage_delete_windows () = Printf.printf "\r%!"; OpamStubs.fillConsoleOutputCharacter hConsoleOutput '\000' w (0, row) |> ignore - | VT100 -> + | VT100 force -> + force (); carriage_delete_unix () let carriage_delete = @@ -435,8 +450,10 @@ let carriage_delete = match get_win32_console_shim `stdout Mode with | Shim -> carriage_delete_windows - | VT100 -> - carriage_delete_unix) + | VT100 force -> + fun () -> + force (); + carriage_delete_unix ()) in fun () -> Lazy.force carriage_delete () else @@ -458,8 +475,10 @@ let clear_status = fun () -> carriage_delete_windows (); displaying_status := false - | VT100 -> - clear_status_unix) + | VT100 force -> + fun () -> + force (); + clear_status_unix ()) in fun () -> Lazy.force clear_status () @@ -564,7 +583,7 @@ let formatted_msg ?indent fmt = let last_status = ref "" -let write_status_unix fmt = +let write_status_unix print_string fmt = let print_string s = print_string s; flush stdout; @@ -584,18 +603,18 @@ let write_status_windows fmt = let win32_print_functions = lazy ( match get_win32_console_shim `stdout Mode with | Shim -> - (true, (fun s -> win32_print_message `stdout (s ^ "\n"))) - | VT100 -> - (false, print_endline)) + (true, (fun s -> win32_print_message `stdout (s ^ "\n")), print_string) + | VT100 force -> + (false, (fun s -> force (); print_endline s), (fun s -> force (); print_string s))) let status_line fmt = let batch = debug () || not (disp_status_line ()) in - let (use_shim, print_msg) = + let (use_shim, print_msg, print_string) = if Sys.win32 then Lazy.force win32_print_functions else - (false, print_endline) + (false, print_endline, print_string) in if batch then Printf.ksprintf @@ -605,7 +624,7 @@ let status_line fmt = if use_shim then write_status_windows fmt else - write_status_unix fmt + write_status_unix print_string fmt let header_width () = min 80 (OpamStd.Sys.terminal_columns ())