diff --git a/configure b/configure index 0b250296491..04182b937b5 100755 --- a/configure +++ b/configure @@ -6088,7 +6088,7 @@ case $TARGET in #( # NOTE: On Windows, the Windows specific dlls should stay dynamic for security reasons # NOTE: -l:libstdc++.a is necessary (vs. -lstdc++) as flexlink will use libstdc++.dll.a # which still depends on the DLL at runtime instead of libstdc++.a (that looks like a bug in flexlink) - platform_dependant_stuff="-cclib -lopam_stubs_win32_stubs -cclib -l:libstdc++.a -cclib -l:libpthread.a -cclib -Wl,-static -cclib -ladvapi32 -cclib -lgdi32 -cclib -luser32 -cclib -lshell32" + platform_dependant_stuff="-cclib -lopam_stubs_win32_stubs -cclib -l:libstdc++.a -cclib -l:libpthread.a -cclib -Wl,-static -cclib -ladvapi32 -cclib -lgdi32 -cclib -luser32 -cclib -lshell32 -cclib -lole32 -cclib -luuid" ;; #( *) : ;; diff --git a/configure.ac b/configure.ac index a9d1a2cc388..fbc22e63e38 100644 --- a/configure.ac +++ b/configure.ac @@ -350,7 +350,7 @@ AS_CASE([$TARGET], # NOTE: On Windows, the Windows specific dlls should stay dynamic for security reasons # NOTE: -l:libstdc++.a is necessary (vs. -lstdc++) as flexlink will use libstdc++.dll.a # which still depends on the DLL at runtime instead of libstdc++.a (that looks like a bug in flexlink) - platform_dependant_stuff="-cclib -lopam_stubs_win32_stubs -cclib -l:libstdc++.a -cclib -l:libpthread.a -cclib -Wl,-static -cclib -ladvapi32 -cclib -lgdi32 -cclib -luser32 -cclib -lshell32" + platform_dependant_stuff="-cclib -lopam_stubs_win32_stubs -cclib -l:libstdc++.a -cclib -l:libpthread.a -cclib -Wl,-static -cclib -ladvapi32 -cclib -lgdi32 -cclib -luser32 -cclib -lshell32 -cclib -lole32 -cclib -luuid" ]) AS_CASE([${support_static},${enable_static}], [no,yes],[AC_MSG_ERROR([--enable-static is not available on this platform (${TARGET}).])], diff --git a/master_changes.md b/master_changes.md index 0999ff4411e..a03112eda3d 100644 --- a/master_changes.md +++ b/master_changes.md @@ -110,6 +110,8 @@ users) ## Internal: Windows * Ensure that the system critical error dialog is disabled when opam starts [#5828 @dra27] * Fix loading git location at init [#5843 @rjbou] + * Remove use of deprecated function SHGetFolderPath and use SHGetKnownFolderPath instead [#5862 @kit-ty-kate] + * Improve performance by only calling OpamStubs.getPathToSystem once [#5862 @dra27] ## Test diff --git a/shell/context_flags.ml b/shell/context_flags.ml index 9e39d5e91d0..1437c9cd6bd 100644 --- a/shell/context_flags.ml +++ b/shell/context_flags.ml @@ -15,7 +15,7 @@ match Sys.argv.(1) with print_string "i686" | "clibs" -> if Sys.win32 then - print_string "(-ladvapi32 -lgdi32 -luser32 -lshell32)" + print_string "(-ladvapi32 -lgdi32 -luser32 -lshell32 -lole32 -luuid)" else print_string "()" | _ -> diff --git a/src/core/opamStd.ml b/src/core/opamStd.ml index 06c184b8894..2c8a0cb8392 100644 --- a/src/core/opamStd.ml +++ b/src/core/opamStd.ml @@ -984,8 +984,7 @@ module OpamSys = struct try Unix.getenv "HOME" with Not_found -> if Sys.win32 then - (* CSIDL_PROFILE = 0x28 *) - OpamStubs.(shGetFolderPath 0x28 SHGFP_TYPE_CURRENT) + OpamStubs.getPathToHome () else Sys.getcwd () ) in @@ -1006,9 +1005,9 @@ module OpamSys = struct Hashtbl.add memo arg r; r - let system () = - (* CSIDL_SYSTEM = 0x25 *) - OpamStubs.(shGetFolderPath 0x25 SHGFP_TYPE_CURRENT) + let system = + let system = Lazy.from_fun OpamStubs.getPathToSystem in + fun () -> Lazy.force system type os = | Darwin diff --git a/src/core/opamStubs.dummy.ml b/src/core/opamStubs.dummy.ml index 8ec1682c8a7..ccc044ef301 100644 --- a/src/core/opamStubs.dummy.ml +++ b/src/core/opamStubs.dummy.ml @@ -31,7 +31,9 @@ let delete_glyph_checker = that's_a_no_no let has_glyph _ = that's_a_no_no let getProcessArchitecture = that's_a_no_no let process_putenv _ = that's_a_no_no -let shGetFolderPath _ = that's_a_no_no +let getPathToHome = that's_a_no_no +let getPathToSystem = that's_a_no_no +let getPathToLocalAppData = that's_a_no_no let sendMessageTimeout _ _ _ _ _ = that's_a_no_no let getProcessAncestry = that's_a_no_no let getConsoleAlias _ = that's_a_no_no diff --git a/src/core/opamStubs.mli b/src/core/opamStubs.mli index 29e8a909757..e9075fc98cf 100644 --- a/src/core/opamStubs.mli +++ b/src/core/opamStubs.mli @@ -105,9 +105,10 @@ val process_putenv : int32 -> string -> string -> bool if the target process is 32-bit and the current process is 64-bit or vice versa (outcomes vary from a no-op to a segfault). *) -val shGetFolderPath : int -> shGFP_type -> string -(** Windows only. [shGetFolderPath nFolder dwFlags] retrieves the location of a special - folder by CSIDL value. See https://msdn.microsoft.com/en-us/library/windows/desktop/bb762181.aspx *) +val getPathToHome : unit -> string +val getPathToSystem : unit -> string +val getPathToLocalAppData : unit -> string +(** Windows only. retrieves the location of the wanted directory *) val sendMessageTimeout : nativeint -> int -> int -> ('a, 'b, 'c) winmessage -> 'a -> 'b -> int * 'c diff --git a/src/core/opamStubsTypes.ml b/src/core/opamStubsTypes.ml index 25e583588dd..683e26c84ee 100644 --- a/src/core/opamStubsTypes.ml +++ b/src/core/opamStubsTypes.ml @@ -67,13 +67,6 @@ type registry_root = type _ registry_value = | REG_SZ : string registry_value -(** SHGetFolderPath flags *) -type shGFP_type = -| SHGFP_TYPE_CURRENT - (** Retrieve the current path *) -| SHGFP_TYPE_DEFAULT - (** Retrieve the default path *) - (** Windows Messages (at least, one of them!) *) type ('a, 'b, 'c) winmessage = | WM_SETTINGCHANGE : (int, string, int) winmessage diff --git a/src/state/opamStateConfig.ml b/src/state/opamStateConfig.ml index 6d1eea5ac7a..b579f7acf42 100644 --- a/src/state/opamStateConfig.ml +++ b/src/state/opamStateConfig.ml @@ -82,8 +82,7 @@ let default = { else let open OpamFilename in let local_appdata = - (* CSIDL_LOCAL_APPDATA = 0x1c *) - Dir.of_string (OpamStubs.(shGetFolderPath 0x1c SHGFP_TYPE_CURRENT)) + Dir.of_string (OpamStubs.getPathToLocalAppData ()) in concat_and_resolve local_appdata "opam" ); diff --git a/src/stubs/win32/opamWin32Stubs.ml b/src/stubs/win32/opamWin32Stubs.ml index 3dfabccbcaa..b5911f9dbd7 100644 --- a/src/stubs/win32/opamWin32Stubs.ml +++ b/src/stubs/win32/opamWin32Stubs.ml @@ -30,7 +30,9 @@ 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 shGetFolderPath : int -> 'a -> string = "OPAMW_SHGetFolderPath" +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" diff --git a/src/stubs/win32/opamWindows.c b/src/stubs/win32/opamWindows.c index 2116ad230b6..5d6e6c46d15 100644 --- a/src/stubs/win32/opamWindows.c +++ b/src/stubs/win32/opamWindows.c @@ -26,6 +26,8 @@ #include #include #include +#include +#include #include @@ -549,24 +551,29 @@ CAMLprim value OPAMW_process_putenv(value pid, value key, value val) caml_failwith(result); } -/* - * Somewhat against my better judgement, wrap SHGetFolderPath rather than - * SHGetKnownFolderPath to maintain XP compatibility. OPAM already requires - * Windows Vista+ because of GetCurrentConsoleFontEx, but there may be a - * workaround for that for XP lusers. - */ -CAMLprim value OPAMW_SHGetFolderPath(value nFolder, value dwFlags) +static value OPAMW_SHGetKnownFolderPath(REFKNOWNFOLDERID rfid) { - WCHAR szPath[MAX_PATH]; - - if (SUCCEEDED(SHGetFolderPath(NULL, - Int_val(nFolder), - NULL, - Int_val(dwFlags), - szPath))) - return caml_copy_string_of_utf16(szPath); - else - caml_failwith("OPAMW_SHGetFolderPath"); + PWSTR path = NULL; + value result; + + if (SUCCEEDED(SHGetKnownFolderPath(rfid, 0, NULL, &path))) { + result = caml_copy_string_of_utf16(path); + CoTaskMemFree(path); + return result; + } else { + CoTaskMemFree(path); + caml_failwith("OPAMW_SHGetKnownFolderPath"); + } +} + +CAMLprim value OPAMW_GetPathToHome(value _unit) { + return OPAMW_SHGetKnownFolderPath(&FOLDERID_Profile); +} +CAMLprim value OPAMW_GetPathToSystem(value _unit) { + return OPAMW_SHGetKnownFolderPath(&FOLDERID_System); +} +CAMLprim value OPAMW_GetPathToLocalAppData(value _unit) { + return OPAMW_SHGetKnownFolderPath(&FOLDERID_LocalAppData); } CAMLprim value OPAMW_SendMessageTimeout(value vhWnd,