From 4c918130c2ed1fe4e85bba63fc0bb032ec0e0a3d Mon Sep 17 00:00:00 2001 From: Kate Date: Mon, 30 Sep 2024 19:23:52 +0100 Subject: [PATCH] Fix the compilation of opam on Windows with OCaml >= 5.0 (again) --- src/core/dune | 4 +++ src/core/opamStubs.ocaml4.ml | 39 +------------------------ src/core/opamStubs.ocaml5.ml | 2 -- src/core/opamWin32Stubs.win32.ml | 49 ++++++++++++++++++++++++++++++++ 4 files changed, 54 insertions(+), 40 deletions(-) create mode 100644 src/core/opamWin32Stubs.win32.ml diff --git a/src/core/dune b/src/core/dune index 723aa44aaab..4fa3e09cdc5 100644 --- a/src/core/dune +++ b/src/core/dune @@ -29,6 +29,10 @@ (enabled_if (<> %{os_type} "Win32")) (action (copy# opamStubs.unix.ml opamStubs.ml))) +(rule + (enabled_if (= %{os_type} "Win32")) + (action (copy# opamWin32Stubs.win32.ml opamWin32Stubs.ml))) + (rule (enabled_if (and (= %{os_type} "Win32") (< %{ocaml_version} "5.0"))) (action (copy# opamStubs.ocaml4.ml opamStubs.ml))) diff --git a/src/core/opamStubs.ocaml4.ml b/src/core/opamStubs.ocaml4.ml index 7763f92837c..ef077a67e8b 100644 --- a/src/core/opamStubs.ocaml4.ml +++ b/src/core/opamStubs.ocaml4.ml @@ -8,45 +8,8 @@ (* *) (**************************************************************************) -include OpamStubsTypes +include OpamWin32Stubs -external getCurrentProcessID : unit -> int32 = "OPAMW_GetCurrentProcessID" -let getpid () = Int32.to_int (getCurrentProcessID ()) -(* Polymorphic parameters below are used as placeholders for types in - * OpamStubsTypes - it's not worth the effort of propagating the types here, - * even if it does result in some ugly-looking primitives! - *) -external getStdHandle : 'a -> 'b = "OPAMW_GetStdHandle" -external getConsoleScreenBufferInfo : 'a -> 'b = "OPAMW_GetConsoleScreenBufferInfo" -external setConsoleTextAttribute : 'a -> int -> unit = "OPAMW_SetConsoleTextAttribute" -external fillConsoleOutputCharacter : 'a -> char -> int -> int * int -> bool = "OPAMW_FillConsoleOutputCharacter" -external getConsoleMode : 'a -> int = "OPAMW_GetConsoleMode" -external setConsoleMode : 'a -> int -> bool = "OPAMW_SetConsoleMode" -external getWindowsVersion : unit -> int * int * int * int = "OPAMW_GetWindowsVersion" -external getArchitecture : unit -> 'a = "OPAMW_GetArchitecture" -external waitpids : int list -> int -> int * Unix.process_status = "OPAMW_waitpids" -external readRegistry : 'a -> string -> string -> 'b -> 'c option = "OPAMW_ReadRegistry" -external enumRegistry : 'a -> string -> 'b -> (string * 'c) list = "OPAMW_RegEnumValue" -external writeRegistry : 'a -> string -> string -> 'b -> 'c -> unit = "OPAMW_WriteRegistry" -external getConsoleOutputCP : unit -> int = "OPAMW_GetConsoleOutputCP" -external getCurrentConsoleFontEx : 'a -> bool -> 'b = "OPAMW_GetCurrentConsoleFontEx" -external create_glyph_checker : string -> 'a * 'a = "OPAMW_CreateGlyphChecker" -external delete_glyph_checker : 'a * 'a -> unit = "OPAMW_DeleteGlyphChecker" -external has_glyph : 'a * 'a -> Uchar.t -> bool = "OPAMW_HasGlyph" -external getProcessArchitecture : int32 option -> 'a = "OPAMW_GetProcessArchitecture" -external process_putenv : int32 -> string -> string -> bool = "OPAMW_process_putenv" -external getPathToHome : unit -> string = "OPAMW_GetPathToHome" -external getPathToSystem : unit -> string = "OPAMW_GetPathToSystem" -external getPathToLocalAppData : unit -> string = "OPAMW_GetPathToLocalAppData" -external sendMessageTimeout : nativeint -> int -> int -> 'a -> 'b -> 'c -> int * 'd = "OPAMW_SendMessageTimeout_byte" "OPAMW_SendMessageTimeout" -external getProcessAncestry : unit -> (int32 * string) list = "OPAMW_GetProcessAncestry" -external getConsoleAlias : string -> string -> string = "OPAMW_GetConsoleAlias" -external getConsoleWindowClass : unit -> string option = "OPAMW_GetConsoleWindowClass" -external setErrorMode : int -> int = "OPAMW_SetErrorMode" -external getErrorMode : unit -> int = "OPAMW_GetErrorMode" -external setConsoleToUTF8 : unit -> unit = "OPAMW_SetConsoleToUTF8" -external getVersionInfo : string -> 'a option = "OPAMW_GetVersionInfo" -external get_initial_environment : unit -> string list = "OPAMW_CreateEnvironmentBlock" external win_create_process : string -> string -> string option -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int = "win_create_process" "win_create_process_native" diff --git a/src/core/opamStubs.ocaml5.ml b/src/core/opamStubs.ocaml5.ml index 74f6c9c8c13..c1b977b837b 100644 --- a/src/core/opamStubs.ocaml5.ml +++ b/src/core/opamStubs.ocaml5.ml @@ -8,9 +8,7 @@ (* *) (**************************************************************************) -include OpamStubsTypes include OpamWin32Stubs -let getpid () = Int32.to_int (getCurrentProcessID ()) external win_create_process : string -> string -> string option -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int diff --git a/src/core/opamWin32Stubs.win32.ml b/src/core/opamWin32Stubs.win32.ml new file mode 100644 index 00000000000..c9286dee923 --- /dev/null +++ b/src/core/opamWin32Stubs.win32.ml @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* Copyright 2018 MetaStack Solutions Ltd. *) +(* *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1, with the special *) +(* exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +include OpamStubsTypes + +external getCurrentProcessID : unit -> int32 = "OPAMW_GetCurrentProcessID" +let getpid () = Int32.to_int (getCurrentProcessID ()) +(* Polymorphic parameters below are used as placeholders for types in + * OpamStubsTypes - it's not worth the effort of propagating the types here, + * even if it does result in some ugly-looking primitives! + *) +external getStdHandle : 'a -> 'b = "OPAMW_GetStdHandle" +external getConsoleScreenBufferInfo : 'a -> 'b = "OPAMW_GetConsoleScreenBufferInfo" +external setConsoleTextAttribute : 'a -> int -> unit = "OPAMW_SetConsoleTextAttribute" +external fillConsoleOutputCharacter : 'a -> char -> int -> int * int -> bool = "OPAMW_FillConsoleOutputCharacter" +external getConsoleMode : 'a -> int = "OPAMW_GetConsoleMode" +external setConsoleMode : 'a -> int -> bool = "OPAMW_SetConsoleMode" +external getWindowsVersion : unit -> int * int * int * int = "OPAMW_GetWindowsVersion" +external getArchitecture : unit -> 'a = "OPAMW_GetArchitecture" +external waitpids : int list -> int -> int * Unix.process_status = "OPAMW_waitpids" +external readRegistry : 'a -> string -> string -> 'b -> 'c option = "OPAMW_ReadRegistry" +external enumRegistry : 'a -> string -> 'b -> (string * 'c) list = "OPAMW_RegEnumValue" +external writeRegistry : 'a -> string -> string -> 'b -> 'c -> unit = "OPAMW_WriteRegistry" +external getConsoleOutputCP : unit -> int = "OPAMW_GetConsoleOutputCP" +external getCurrentConsoleFontEx : 'a -> bool -> 'b = "OPAMW_GetCurrentConsoleFontEx" +external create_glyph_checker : string -> 'a * 'a = "OPAMW_CreateGlyphChecker" +external delete_glyph_checker : 'a * 'a -> unit = "OPAMW_DeleteGlyphChecker" +external has_glyph : 'a * 'a -> Uchar.t -> bool = "OPAMW_HasGlyph" +external getProcessArchitecture : int32 option -> 'a = "OPAMW_GetProcessArchitecture" +external process_putenv : int32 -> string -> string -> bool = "OPAMW_process_putenv" +external getPathToHome : unit -> string = "OPAMW_GetPathToHome" +external getPathToSystem : unit -> string = "OPAMW_GetPathToSystem" +external getPathToLocalAppData : unit -> string = "OPAMW_GetPathToLocalAppData" +external sendMessageTimeout : nativeint -> int -> int -> 'a -> 'b -> 'c -> int * 'd = "OPAMW_SendMessageTimeout_byte" "OPAMW_SendMessageTimeout" +external getProcessAncestry : unit -> (int32 * string) list = "OPAMW_GetProcessAncestry" +external getConsoleAlias : string -> string -> string = "OPAMW_GetConsoleAlias" +external getConsoleWindowClass : unit -> string option = "OPAMW_GetConsoleWindowClass" +external setErrorMode : int -> int = "OPAMW_SetErrorMode" +external getErrorMode : unit -> int = "OPAMW_GetErrorMode" +external setConsoleToUTF8 : unit -> unit = "OPAMW_SetConsoleToUTF8" +external getVersionInfo : string -> 'a option = "OPAMW_GetVersionInfo" +external get_initial_environment : unit -> string list = "OPAMW_CreateEnvironmentBlock"